Code copier coller à parfaire
Bonsoir le forum
J'ai un code qui normalement devrait me permettre de copier des données d'un classeur et les coller sur un autre suivant certaines conditions.
Lorsque j'exécute la macro, les éléments à copier sont effacés et le collage ne se réalise pas non plus.
Ci-dessous le besoin initiale:
Citation:
Je viens solliciter votre aide pour un travail important.
En effet, j’ai deux (2) fichiers.
A partir du fichier de départ« ETAT_RECAP_1 » je dois copier les données et les coller sur le fichier « Fiche_Base ».
Seuls les éléments de la colonne c du fichier «ETAT_RECAP_1» ayant leur correspondance dans la colonne c du fichier de destination (Fiche_Base) devront être collés sinon pas de collage.
Les données du fichier de départ (C:I) doivent être collées respectivement (et sur la ligne correspondante) en C, D, E, H, J, L et N.
Suivant l’esprit de notre besoin, si tout se passe bien, les éléments colorés en jaune du fichier "ETAT_RECAP_1" devront être copiés et collés sur le fichier « FICHE_BASE »
Ci-dessous le code réalisé pour appréciation car ne donne pas satisfaction:
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
| Sub rapproche()
Dim c, Cel
Dim Source As Workbook
Dim Cible As Workbook
Dim Client
Chemin = ActiveWorkbook.Path
'ChDir Chemin
'Nomfich = Application.GetOpenFilename("documents excel(*.xlsx),*.xlsx", , , , True)
On Error Resume Next
Set Ws1 = Worksheets("ETAT")
Set Ws2 = Workbooks("fiche_base.xlsx")
Ws1.Select
Set Cible = ActiveWorkbook
Set Client = Ws1.Range("C5:C" & [C80000].End(xlUp).Row)
For Each Cel In Client
'Client = Cel.Value
With Ws2.Sheets("feuil1").Range("c:c")
Set c = .Find(What:=Cel, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
Cel.Offset(0, 1).Value = c.Offset(0, 1) ' nom
Cel.Offset(0, 2).Value = c.Offset(0, 2) ' tel
Cel.Offset(0, 3).Value = c.Offset(0, 5) ' date naiss
Cel.Offset(0, 4).Value = c.Offset(0, 7) ' civilité
Cel.Offset(0, 5).Value = c.Offset(0, 9) ' sit matr
Cel.Offset(0, 6).Value = c.Offset(0, 11) ' profession
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next Cel
End Sub |
