Contrôle avant transfert des données

Bonsoir;

Pourriez-vous m'aider à ajouter à ma macro qui est comme objet de transfert des données depuis la feuille 1 a la feuille 2 selon la date

l'amélioration à faire est de contrôler la ligne à transfert si la date est dans l'intervalle de tableau sur la feuille 2, sinon un message d'alerte apparaissait.

Merci d'avance.

Mon fichier ci-joint

4test-qr-230530.xlsm (114.29 Ko)

Bonjour,

Sub transfert()

Dim lig As Long

  If DateDansLAnnee(CDate(Sheets("Feuil1").Range("C26")), Range("Tab_JRS[Date]")) = True Then
        lig = 1 + Range("C26").Value - [Tab_JRS].Item(1, 3)
        [Tab_JRS].Item(lig, 4) = Range("D26").Value
        [Tab_JRS].Item(lig, 5) = Range("E26").Value
        [Tab_JRS].Item(lig, 6) = Range("F26").Value
        [Tab_JRS].Item(lig, 7) = Range("G26").Value
        MsgBox ("Transfert effectué")
  Else
        MsgBox "La date n'est pas dans l'année !", vbCritical
  End If

End Sub

Function DateDansLAnnee(ByVal DateF1 As Date, ByVal AireDatesF2 As Range) As Boolean

Dim I As Integer

    DateDansLAnnee = False
    For I = 1 To AireDatesF2.Count
        If CDate(AireDatesF2(I)) = DateF1 Then
           DateDansLAnnee = True
           Exit Function
        End If
    Next I

End Function

Bonjour à toutes et tous,
Une autre proposition.
Bonne journée.

5test-qr-230530.xlsm (114.56 Ko)
Public Sub Transfert()
Dim lo As ListObject, dt As Long, tbl, rw
    With Worksheets("Feuil1").Cells(26, 3)
        dt = .Value
        tbl = .Offset(, 1).Resize(, 4).Value
    End With
    Set lo = Range("Tab_JRS").ListObject
    rw = Application.Match(dt, lo.ListColumns("Date").DataBodyRange, 0)
    If IsError(rw) Then
        MsgBox " La date n'est pas dans l'intervalle !...", 64, "Transfert"
    Else
        lo.DataBodyRange.Cells(rw, 4).Resize(, 4).Value = tbl
        MsgBox "Transfert réalisé !...", 64, "Transfert"
    End If
End Sub

super merci, mais aurait il possible si je fais une date sur la colonne C26 feuille 1 une date exemple 15/02/2023 sur le tableau au feuille 2 la colonne date filtre sur le mois de Février.

j'ai un autre souci c'est que quand les cellules sont vides le transfert ne devrait pas être fait

merci.

Edit j'ai un autre souci c'est que quand les cellules sont vides le transfert ne devrait pas être fait

Avec une formule NbVal en H26, vous comptez le nombre de valeurs dans vos 4 cellules et vous lancez ou pas en fonction du résultat.

Merci Eric, mais est il possible de l'ajouter à la macro ,

Re?
Une mise à jour à adapter !?
Cdlt.

Public Sub Transfert_2()
Dim lo As ListObject, dt As Long, tbl, rw, r As Range, n As Double

    With Worksheets("Feuil1")
        Set r = .Cells(26, 3).Resize(, 5)
        n = WorksheetFunction.CountA(r)
        If n = 5 Then
            With .Cells(26, 3)
                dt = .Value
                tbl = .Offset(, 1).Resize(, 4).Value
            End With
            Set lo = Range("Tab_JRS").ListObject
            rw = Application.Match(dt, lo.ListColumns("Date").DataBodyRange, 0)
            If IsError(rw) Then
                MsgBox " La date n'est pas dans l'intervalle !...", 64, "Transfert"
            Else
                lo.DataBodyRange.Cells(rw, 4).Resize(, 4).Value = tbl
                MsgBox "Transfert réalisé !...", 64, "Transfert"
            End If
        Else
            MsgBox "La procédure ne peut pas être exécutée !...", 64, "Information"
        End If
    End With

End Sub

Merci Jean-Eric pour votre réponse, mais il me reste seulement l'option

aurait il possible si je fais une date sur la colonne C26 feuille 1 une date exemple 15/02/2023 sur le tableau au feuille 2 la colonne date filtre sur le mois de Février.

Merci d'avance

Bonjour,
Une mise à jour de la procédure pour intégrer le filtre sur le mois.
Cdlt.

Public Sub Transfert()
Dim lo As ListObject, dt, tbl, rw
    With Worksheets("Feuil1").Cells(26, 3)
        dt = .Value2
        tbl = .Offset(, 1).Resize(, 4).Value
    End With
    Set lo = Range("Tab_JRS").ListObject
    rw = Application.Match(dt, lo.ListColumns("Date").DataBodyRange, 0)
    If IsError(rw) Then
        MsgBox " La date n'est pas dans l'intervalle !...", 64, "Transfert"
    Else
        With lo
            If .ShowAutoFilter Then .AutoFilter.ShowAllData
            .DataBodyRange.Cells(rw, 4).Resize(, 4).Value = tbl
            dt = Format(dt, "mm/dd/yyyy")
            .Range.AutoFilter field:=3, Operator:=7, Criteria2:=Array(1, dt)
        End With
        MsgBox "Transfert réalisé !...", 64, "Transfert"
    End If
End Sub

Merci bcp @Jean-Eric

Rechercher des sujets similaires à "controle transfert donnees"