VBA: recherche et copie cellules entre fichiers

[Berna]

Bonjour à tous,

J'écris pour la première fois sur ce forum car malgré de nombreuses recherches et tentatives, je n'arrive pas à terminer complétement une macro sur laquelle je travaille depuis plusieurs jours... Je viens donc demander l'aide de spécialistes VBA!

Je vous explique mon problème:

J'ai deux fichiers excel:
- "Base": un fichier source que j'alimente régulièrement avec de nouvelles lignes (plusieurs colonnes avec plusieurs infos) et avec la mise à jour de certaines informations sur les lignes déjà existantes
- "Destination": un fichier de destination que je souhaite mettre à jour une fois par mois à partir de la base, avec l'ensemble des lignes et les différentes colonnes.

Je peux croiser les données grâce à un code spécifique sur chaque ligne (dans cet exemple en colonne A), et donc assez facilement envoyer les données de la base vers la destination.

Mais il y a plusieurs difficultés:
- les lignes ne sont pas nécessairement dans le même ordre et peuvent évoluer selon les mois
- et surtout, de nouvelles lignes (avec donc à chaque fois un nouveau code) peuvent apparaitre dans le fichier "base". Il faut donc que la macro cherche les lignes communes entre chaque fichier et mette à jour les infos de la ligne, puis qu'elle repère les lignes pas encore existantes dans le fichier de destination pour les créer à la suite des lignes existantes (avec bien sûr également toutes les infos de la ligne).

Concretement cela donne:
"Base", feuille "data"
Colonne A Colonne B Colonne C
000001 Marseille 18
009999 Lyon 20
009899 Paris 498
324558 Marseille 20


"Destination" feuille "portfolio"
Colonne A Colonne B Colonne C
009999 Lyon 10
009899 Paris 418
324558 Marseille 15

Je souhaite donc mettre à jour les infos des colonnes B et C et creer la ligne manquante à la suite.

Voici la macro que j'ai réussi à écrire: elle met les infos à jour mais je ne parviens pas à détecter et créer à la suite les lignes manquantes.

-------

Sub RechercheCopie()


Dim Destination As Workbook
Dim Base As Workbook

Dim DerLigne As Long


Empacement_Destination = Cells(5, 1).Value
Name_Destination = Cells(8, 1).Value


Workbooks.Open Filename:=ThisWorkbook.Path & "\" & Name_Destination & ".xlsm"


Set Destination = ActiveWorkbook
Set Base = ThisWorkbook


Dim Code As String, i As Long, j As Long, DernLigne As Long
Sheets("portfolio").Select
i = 2

With Base.Sheets("data")
Do While Cells(i, 1) <> ""
Code = Cells(i, 1)
For j = 1 To .Range("A65536").End(xlUp).Row
If Code = .Cells(j, 1) Then
Cells(i, 1) = .Cells(j, 1)
Cells(i, 2) = .Cells(j, 2)
Cells(i, 3) = .Cells(j, 3)

End If
Next
i = i + 1
Loop

End With

'Coince à partir de là...

DerLigne = Sheets("portfolio").Range("A" & Rows.Count).End(xlUp).Row

With Base.Sheets("data")
Do While Cells(i, 1) <> ""
Code = Cells(i, 1)
For j = 1 To .Range("A65536").End(xlUp).Row

If Code <> Cells(i, 1) Then

Cells(i, 1) = .Cells(DerLigne, 1)
Cells(i, 2) = .Cells(DerLigne, 2)
Cells(i, 3) = .Cells(DerLigne, 3)

End If
Next
i = i + 1
Loop

End With


End Sub

------

Peut-être avec "else" après le premier if ?
Mais je n'ai pas réussi...

Je remercie par avance tout ceux qui pourraient se pencher sur mon cas et m'aider dans la résolution de ce problème.

Bernard

 

[jpb388]

Re : VBA: recherche et copie cellules entre fichiers

Bonjour à tous
regarde si cela te vas

Option Explicit

Sub RechercheCopie()
    ' définition variable
    Dim Dest As Workbook, Base As Workbook ' classeur
    Dim Der_lg_Base As Long, Der_lg_Dest As Long, Lg As Integer   ' recherche de ligne
    Dim i As Integer, j As Integer ' boucle
    Dim Rech_Code As Long
    '
    Set Base = ActiveWorkbook
    Der_lg_Base = Sheets("data").Range("a" & Rows.Count).End(xlUp).Row
    ' ouverture destination
    Workbooks.Open ThisWorkbook.Path & "\destination.xlsx"
    Set Dest = ActiveWorkbook
    '
    Sheets("Portfolio").Select
    For i = 2 To Der_lg_Base
        Der_lg_Dest = Sheets("Portfolio").Range("a" & Rows.Count).End(xlUp).Row
        Rech_Code = Base.Sheets("Data").Range("a" & i).Value
        On Error Resume Next
         Err = 0
       Lg = Range("A1:A" & Der_lg_Dest).Find(Rech_Code).Row
       If Err = 0 Then
          Cells(Lg, 3) = Base.Sheets("Data").Range("c" & i).Value
        Else
          Cells(Der_lg_Dest + 1, 1) = Rech_Code
          Cells(Der_lg_Dest + 1, 2) = Base.Sheets("Data").Range("b" & i).Value
          Cells(Der_lg_Dest + 1, 3) = Base.Sheets("Data").Range("c" & i).Value
    End If
    On Error GoTo 0
    Next i
End Sub

 

[Berna]

Re : VBA: recherche et copie cellules entre fichiers

Bonjour JP,

Merci pour ta réponse: cela marche nickel!
J'adapte cela en début de semaine prochaine avec mes vrais fichiers (beaucoup plus lourds que ceux de l'exemple et avec bien plus d'informations à renvoyer), et je comparerai avec une solution que j'ai trouvé aujourd'hui mais qui est très longue à tourner...
Je posterai la meilleure solution!