Deplacer plage de cellules

Bonjour à tous,

Le 1er code déplace les cellules comme il se doit. Comme je dois déplacer ces mêmes cellules sur plusieurs feuilles comme vous pouvez le voir vers "Cumul, CumulS, CumulM"

Le Sub DeplaceJ m'efface la plage de cellules de la feuille de Données donc :

Le Sub DeplaceS et DeplaceM ne peux plus rien déplacer car les cellules que je lui demande de déplacer sont vides.

Sub DeplaceJ() 'Cumul Jour
 Dim dlg As Integer, lg As Integer
 With Sheets("Données")
 dlg = .Range("D" & .Rows.Count).End(xlUp).Row
If dlg > 9 Then
        lg = Sheets("Cumul").Range("a" & Sheets("Cumul").Rows.Count).End(xlUp).Row
      If lg = 2 Then lg = lg + 1
   .Range("A10:D" & dlg).Cut Sheets("Cumul").Range("A" & lg)
    End If
End With
End Sub
Sub DeplaceS() 'Cumul Semaine
 Dim dlg As Integer, lg As Integer
 With Sheets("Données")
 dlg = .Range("D" & .Rows.Count).End(xlUp).Row
If dlg > 9 Then
        lg = Sheets("CumulS").Range("a" & Sheets("CumulS").Rows.Count).End(xlUp).Row
    If lg = 2 Then lg = lg + 1
      .Range("A10:D" & dlg).Cut Sheets("CumulS").Range("A" & lg)
    End If
End With
End Sub
Sub DeplaceM() 'Cumul Mois
 Dim dlg As Integer, lg As Integer
 With Sheets("Données")
 dlg = .Range("D" & .Rows.Count).End(xlUp).Row
If dlg > 9 Then
        lg = Sheets("CumulM").Range("a" & Sheets("CumulM").Rows.Count).End(xlUp).Row
    If lg = 2 Then lg = lg + 1
        .Range("A10:D" & dlg).Cut Sheets("CumulM").Range("A" & lg)
    End If
End With

End Sub

Quelqu'un pourrait me dire comment faire soit pour unir le déplacement des cellules sur 3 feuilles distinctes

Soit que les code suivants jouent leur rôle de déplacement des cellules vers les feuilles "CumulS et CumulM"

Merci d'avance de votre aide

Amicalement

Noel

Bonjour,

Tu copie deux fois et et à la troisième tu déplaces :

Sub DeplaceJ() 'Cumul Jour (COPIE)
Dim dlg As Integer, lg As Integer
 With Sheets("Données")
 dlg = .Range("D" & .Rows.Count).End(xlUp).Row
If dlg > 9 Then
        lg = Sheets("Cumul").Range("a" & Sheets("Cumul").Rows.Count).End(xlUp).Row
      If lg = 2 Then lg = lg + 1
   .Range("A10:D" & dlg).Copy Sheets("Cumul").Range("A" & lg)
    End If
End With
End Sub
Sub DeplaceS() 'Cumul Semaine (COPIE)
Dim dlg As Integer, lg As Integer
 With Sheets("Données")
 dlg = .Range("D" & .Rows.Count).End(xlUp).Row
If dlg > 9 Then
        lg = Sheets("CumulS").Range("a" & Sheets("CumulS").Rows.Count).End(xlUp).Row
    If lg = 2 Then lg = lg + 1
      .Range("A10:D" & dlg).Copy Sheets("CumulS").Range("A" & lg)
    End If
End With
End Sub
Sub DeplaceM() 'Cumul Mois (DEPLACE)
Dim dlg As Integer, lg As Integer
 With Sheets("Données")
 dlg = .Range("D" & .Rows.Count).End(xlUp).Row
If dlg > 9 Then
        lg = Sheets("CumulM").Range("a" & Sheets("CumulM").Rows.Count).End(xlUp).Row
    If lg = 2 Then lg = lg + 1
        .Range("A10:D" & dlg).Cut Sheets("CumulM").Range("A" & lg)
    End If
End With

End Sub

Bonjour,

Avec une seule procédure ?

Cdlt.

Sub Deplace()
'déclaration des variables
Dim lastRow As Long, lRow As Long
Dim rng As Range
    lastRow = Worksheets("Données").Cells(Rows.Count, 4).End(xlUp).Row
    If lastRow > 9 Then
        'Plage de données à copier
        Set rng = Worksheets("Données").Cells(10, 1).Resize(lastRow - 9, 4)
        'Cumul jour
        lRow = Worksheets("Cumul").Cells(Rows.Count, 1).End(xlUp).Row + 1
        rng.Copy Destination:=Worksheets("Cumul").Cells(lRow, 1)
        'Cumul semaine
        lRow = Worksheets("CumulS").Cells(Rows.Count, 1).End(xlUp).Row + 1
        rng.Copy Destination:=Worksheets("CumulS").Cells(lRow, 1)
        'Cumul mois
        lRow = Worksheets("CumulM").Cells(Rows.Count, 1).End(xlUp).Row + 1
        rng.Copy Destination:=Worksheets("CumulM").Cells(lRow, 1)
    End If
    'Efface les données copiées
    rng.ClearContents
    'RAZ variables
    Set rng = Nothing
End Sub

Re

Un grand merci à vous deux.

Dés aujourd'hui je peux fermer ce fil

@+

Amicalement

Noel