Macro copier données selon condition

[Anto35200]

Bonjour,

J'ai une macro qui me permets de copier les données d'une plage de cellules vers un autre fichier.
La macro copie ne copie les données qu'une fois, sinon il y a un message. Je souhaiterai inclure dans le code de la macro, que si on est le le 1er jour de la semaine, donc lundi, elle me copie 3 fois ces données.

Par avance, merci.

Dim WsS As Worksheet, WsC As Worksheet
Dim DerDte As Date
    On Error GoTo ouvrirDoc
    Set WsS = ThisWorkbook.Worksheets("Tréso") 'Feuille source
  Set WsC = Workbooks("REPORTING TRESORERIE.xlsx").Sheets("Tréso") 'Feuille cible
  Application.ScreenUpdating = False
    DerDte = WsC.Cells(Rows.Count, "A").End(xlUp).Value
    If DerDte = WsS.Cells(2, "A").Value Then
        MsgBox "Les données du " & DerDte & " ont déjà été reportées !", 16
        End
    Else
        WsS.Range("A2:M" & WsS.Range("A" & Rows.Count).End(xlUp).Row).Copy
        WsC.Cells(Rows.Count, "A").End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
    End If
    Application.CutCopyMode = xlCopy
    MsgBox "Mise à jour effectuée avec succès !"
    Set WsC = Nothing: Set WsS = Nothing
    Exit Sub
ouvrirDoc:
    MsgBox "Ouvrez le fichier ''REPORTING TRESORERIE ''", 16
End Sub

 

[Paf]

Re : Macro copier données selon condition

Bonjour

sans classeur pour tester, une proposition:

Dim WsS As Worksheet, WsC As Worksheet
Dim DerDte As Date
Dim Fin as Byte, i as Byte

    On Error GoTo ouvrirDoc
    Set WsS = ThisWorkbook.Worksheets("Tréso") 'Feuille source
  Set WsC = Workbooks("REPORTING TRESORERIE.xlsx").Sheets("Tréso") 'Feuille cible
  Application.ScreenUpdating = False
    DerDte = WsC.Cells(Rows.Count, "A").End(xlUp).Value
    If DerDte = WsS.Cells(2, "A").Value Then
        MsgBox "Les données du " & DerDte & " ont déjà été reportées !", 16
        End
    Else
        If Format(Date, "dddd") = "lundi" Then  ' si nous sommes lundi
            Fin = 3                                        ' 
        Else
            Fin = 1
        End If
        For i = 1 To Fin  ' copie en 1 fois si pas lundi et 3 fois si lundi
           WsS.Range("A2:M" & WsS.Range("A" & Rows.Count).End(xlUp).Row).Copy
           WsC.Cells(Rows.Count, "A").End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
        Next i
    End If
    Application.CutCopyMode = xlCopy
    MsgBox "Mise à jour effectuée avec succès !"
    Set WsC = Nothing: Set WsS = Nothing
    Exit Sub
ouvrirDoc:
    MsgBox "Ouvrez le fichier ''REPORTING TRESORERIE ''", 16
End Sub

A+