Macro copie entre deux classeur excel avec condition de copie

fikovic

XLDnaute Nouveau
bonjour,

voila je suis débutant en VBA et j'essai de mettre en place une macro qui me permet de copier une plage de cellules d'une fichier source vers un fichier destination se trouvant dans un autre dossier,
les ligne à copier doivent répondre à une condition colonne A à OUI

a chaque fois j'ai le message d'erreur 1004

A COPIER donnée A B C
NON AZRT 47222795 MAU 1234
NON ALG 49344416 MAU 1235
OUI KFC01 49416837 46L 1236
OUI ZODE01 49696389 46L 1237
OUI KALEL 49696400 46L 1238
OUI JOREL 49712616 CLS 1239
OUI COCINEL 49867208 CLX 1240
OUI BIZARD 50959868 MXB 1241


c'est la ligne suivante qui me fait defaut à chaque fois
wbksource.Sheets("SOURCE").Range(Cells(i, "B"), Cells(i, "J")).Copy Destination:=wbkdest.Sheets("DEST").Cells(DerLigneF3, "A")


_____________________________________________
voici le code
Sub copier1()
Dim i, DerLigneF3 As Integer

Dim wbksource As Workbook, wbkdest As Workbook, x As Variant, fin&, fin1&
Dim f As Object, Fso As Object, adr$, adrd$

Dim ws As Worksheet


Set Fso = CreateObject("Scripting.FileSystemObject")
adr = ThisWorkbook.Path
Set wbksource = ThisWorkbook
Application.ScreenUpdating = False

MsgBox adr

For Each ws In wbksource.Worksheets



adrd = "d:\LocalData\ax16211\Desktop\TEST COPY\DESTINATION"
''MsgBox adrd
Application.ScreenUpdating = False
For Each f In Fso.GetFolder(adrd).Files
If Not f = ThisWorkbook.FullName And Not f Like "*~$*" Then
Set wbkdest = Workbooks.Open(f)
''MsgBox wbkdest.Name
With wbkdest.Sheets("DEST")
fin1 = wbkdest.Sheets("DEST").Range("A" & Rows.Count).End(xlUp).Row
If fin1 < 3 Then GoTo 4
'.Range("A3:S" & .Range("A65536").End(xlUp).Row).Clear
4 fin = wbksource.Sheets("SOURCE").Range("B" & Rows.Count).End(xlUp).Row
If fin < 3 Then GoTo 3
''wbksource.Sheets("APPRO").Range("A3:I" & wbksource.Sheets("APPRO").Range("A" & Rows.Count).End(xlUp).Row).Copy .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
For i = 1 To wbksource.Sheets("SOURCE").Cells(Rows.Count, "B").End(xlUp).Row
'' erire le code relatif à la copie a partire du fichier source
If wbksource.Sheets("SOURCE").Cells(i, "A") = "OUI" Then
wbksource.Sheets("SOURCE").Cells(i, "A") = "NON"
wbksource.Sheets("SOURCE").Cells(i, "F") = Now()
''MsgBox wbksource.Sheets("CLV").Cells(i, "A").Value

DerLigneF3 = wbkdest.Sheets("DEST").Cells(Rows.Count, "A").End(xlUp).Row + 1
'' MsgBox DerLigneF3
Application.ScreenUpdating = False

wbksource.Sheets("SOURCE").Range(Cells(i, "B"), Cells(i, "J")).Copy Destination:=wbkdest.Sheets("DEST").Cells(DerLigneF3, "A")

End If

Next i

3 wbkdest.Close 1
End With
End If
Next f







''MsgBox ws.Name

Next



Application.ScreenUpdating = True
MsgBox "C'est fini", , "Traitement Terminé"
End Sub

---------------------------------------------------------------------------------

je vous remercie par avance pour votre aide
 

Pièces jointes

  • TEST COPY.zip
    25.7 KB · Affichages: 24
Dernière édition:

Yaloo

XLDnaute Barbatruc
Re : Macro copie entre deux classeur excel avec condition de copie

Bonjour Fikovic et bienvenu sur XLD,

En remplaçant par
With wbksource.Sheets("SOURCE")
.Range(.Cells(i, "B"), .Cells(i, "J")).Copy Destination:=wbkdest.Sheets("DEST").Cells(DerLigneF3, "A")
End With
ça doit fonctionner.

Tu essais de copier des données de ton fichier source alors que les cellules que tu prends sont celles du classeur Destination puisque c'est celui qui est actif.
A+

Martial
 

fikovic

XLDnaute Nouveau
Re : Macro copie entre deux classeur excel avec condition de copie

Effectivement ty as tout a fait raison je viens de rendre compte que la boucle for est a l'intérieur du with du fichier destination ... je suis bête

En tout cas je te remercie infiniment


Yaloo
 

Discussions similaires

Réponses
6
Affichages
202

Statistiques des forums

Discussions
311 733
Messages
2 082 019
Membres
101 872
dernier inscrit
Colin T