Discussion :

[capi81]

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:

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Marc-L]

Bonjour,

les variables c et Cel doivent être déclarées comme Range …



_____________________________________________________________________________________________________
Je suis Charlie, Bardo, Sousse

[capi81]

Bonsoir Marc-L

Merci pour votre contribution.
Je viens corriger mais toujours le même comportement.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Dim c, cel as range

[Marc-L]

Pour un copier (non présent dans le code), c'est comme indiqué dans l'aide VBA :

Source.Copy Destination où

Source et Destination doivent respecter le modèle objet d'Excel : Application/Workbooks/Worksheets/Range …

Si le code ne donne pas le résultat attendu, la conception est juste mauvaise !
Désactiver On Error (très mauvais cela !) puis suivre le code en mode pas à pas via la touche F8
et contrôler la fenêtre des Variables locales …

Traduire le code en langage parlé et comparer avec ce qui doit être réalisé, cela aide aussi !

Et lorsqu'il y a une condition à la copie, le plus efficace est le filtre avancé …
Et ne pas oublier l'Enregistreur de macros !

[SfJ5Rpw8]

Bonsoir Marc-L

Merci pour votre contribution.
Je viens corriger mais toujours le même comportement.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Dim c, cel as range

non avec ce code seul Cel est un range ... pas C ...

http://bbil.developpez.com/tutoriel/...ariables#LXIII

[patricktoulon]

bonsoir
bon a parfaire il y aurait plusieurs choses a dire

tu aurais pus utiliser application.union sur les cellule non contiguës désiré
et comme on te la dis précédemment copy destination:= ou utiliser un array

dans ce sens j'ai utiliser un array ce qui fait la meme chose

apres avant la ligne de transfert il y a certainement des choses inutiles

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub rapproche()
Dim c As Range, Cel As Range
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
        With c: ligne = Array(.Offset(0, 1), .Offset(0, 2), .Offset(0, 5), .Offset(0, 7), .Offset(0, 9), .Offset(0, 11)): End With
          Cel.Offset(0, 1).Resize(1, 5) = ligne
           Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> FirstAddress
       End If
      End With
    Next Cel
  End Sub

[capi81]

Bonsoir Patricktoulon

Merci pour votre solution.
Je viens de le tester mais sans gain de cause.