Macro permettant de copier/coller des colonnes

Bonjour à tous,

Dans un fichier j'ai des éléments saisies manuellement sur plusieurs colonnes (commencant à partir de la 2ème ligne), j'aimerai qu'une macro vienne lire ces éléments et les colle sur un autre fichier (à partir de la 2ème ligne ). J'ai essayé avec ce code mais je n'ai pas réussi.

Sub CopierFeuilles()

Dim Source(), Cible(), Tablo

Dim MaPlage As Range

Dim DerLig As Long

Dim Wk1 As Workbook

Dim Wk2 As Workbook

Dim Ws1 As Worksheet

Dim Ws2 As Worksheet

Set Wk1 = Workbooks("Classeur1.xlsm")

Set Wk2 = Workbooks("Classeur2.xlsm")

Set Ws1 = Wk1.Worksheets("Feuil1")

Set Ws2 = Wk2.Worksheets("Feuil1")

DerLig = Ws1.Range("Y" & Ws1.Rows.Count).End(xlUp).Row

For i = 2 To DerLig

Tablo = Split(Ws1.Range("Y" & i), "-")

Ws1.Range(Ws1.Cells(i, "Y"), Ws1.Cells(i, "Y").Offset(0, UBound(Tablo))) = Tablo

Next i

'Copier/coller classeur 1 vers classeur2

Source = Array("A", "C", "L", "K", "AD", "AH", "Z")

Cible = Array("A", "B", "D", "E", "F", "G", "C")

For i = 0 To UBound(Source)

DerLig = Ws1.Range(Source(i) & Ws1.Rows.Count).End(xlUp).Row

Set MaPlage = Ws1.Range(Ws1.Cells(2, Source(i)), Ws1.Cells(DerLig, Source(i)))

MaPlage.Copy Destination:=Ws2.Range(Cible(i) & 3)

Set MaPlage = Nothing

Next

Set Ws1 = Nothing

Set Ws2 = Nothing

Set Wk1 = Nothing

Set Wk2 = Nothing

End Sub

Merci d'avance

Bonsoir,

Qu'est-ce que tu ne parviens pas à faire ?

je ne vois pas de problème avec ce code.

Sans doute n'est-il pas addapté à la structure de ton classeurA et de ta feuil1

Pourrais-tu fournir une exemple du classeurA ?

Ci_joint les deux fichiers

J'avais essayé d'adapter le code à mes fichiers mais cela n'avais pas fonctionné

Merci

Je viens de comprendre mon erreur, ca marche de mon coté par contre j'ai un décalage d'une ligne entre le fichier saisi et la base de donnée

bonsoir,

voici un code adapté selon ma compréhension de ce que tu voulais faire

Sub CopierFeuilles()

Dim DerLig As Long, Derligt As Long
Dim Wk1 As Workbook
Dim Wk2 As Workbook
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet

Set Wk1 = Workbooks("Classeur1.xlsx")
Set Wk2 = Workbooks("Classeur2.xlsx")
Set Ws1 = Wk1.Worksheets("element saisi")
Set Ws2 = Wk2.Worksheets("base de données")

' dernière ligne du classeur 1
DerLig = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row

' dernière ligne du classeur 2
Derligt = Ws2.Range("A" & Ws1.Rows.Count).End(xlUp).Row
'Copier/coller classeur 1 vers classeur2 après la dernière ligne du classeur 2
Ws1.Range("A2:J" & DerLig).Copy Destination:=Ws2.Range("A" & Derligt + 1)

Set Ws1 = Nothing
Set Ws2 = Nothing
Set Wk1 = Nothing
Set Wk2 = Nothing
End Sub

Merci beaucoup, votre programme fonctionne parfaitement, j'ai une dernière question si mon fichier saisi évolu (Nb de colonne), j'aurai juste cette ligne à changer ?

Ws1.Range("A2:J" & DerLig).Copy Destination:=Ws2.Range("A" & Derligt + 1)

tartar a écrit :

Merci beaucoup, votre programme fonctionne parfaitement, j'ai une dernière question si mon fichier saisi évolu (Nb de colonne), j'aurai juste cette ligne à changer ?

Ws1.Range("A2:J" & DerLig).Copy Destination:=Ws2.Range("A" & Derligt + 1)

rebonsoir,

oui c'est correct.

ci-dessous le code modifié pour s'adapter au nombre de colonnes trouvées dans le classeur 1

Sub CopierFeuilles()

Dim DerLig As Long, Derligt As Long
Dim Wk1 As Workbook
Dim Wk2 As Workbook
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet

Set Wk1 = Workbooks("Classeur1 (3).xlsx")
Set Wk2 = Workbooks("Classeur2 (2).xlsx")
Set Ws1 = Wk1.Worksheets("element saisi")
Set Ws2 = Wk2.Worksheets("base de données")

' dernière ligne du classeur 1
DerLig = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row
' dernière colonne du classeur 1
dercol = Ws1.Cells(1, Columns.Count).End(xlToLeft).Column

' dernière ligne du classeur 2
Derligt = Ws2.Range("A" & Ws1.Rows.Count).End(xlUp).Row
'Copier/coller classeur 1 vers classeur2 après la dernière ligne du classeur 2
' la plage copiée  va de la ligne 2 colonne 1 à la dernière ligne dernière colonne
Ws1.Range(Ws1.Cells(2, 1), Ws1.Cells(DerLig, dercol)).Copy Destination:=Ws2.Range("A" & Derligt + 1)

Set Ws1 = Nothing
Set Ws2 = Nothing
Set Wk1 = Nothing
Set Wk2 = Nothing
End Sub