comparaison entre 2 fichiers VBA

MELL90

XLDnaute Nouveau
Bonjour,

Je suis désolé pour le dérangement, je débute en VBA et je réalise mon premier code..

En effet j’ai passé toute la matinée pour chercher comment faire une comparaison entre deux fichiers Excel qui contient des informations différentes sauf le nom et le prénom en commun.

J’ai besoin de faire une comparaison entre les deux fichiers A et B et si je trouve une ligne dans A qui ne se trouve pas dans le fichier B je l’insert dans B..

J’ai trouvé plusieurs lignes de codes sur internet j’ai essayé de l’adapter selon mes besoins mais sans résultat puisque je débute en VBA …et je ne comparant pas trop les lignes de code..

Quelqu’un peut ’aider s’il vous pelait.
 

MELL90

XLDnaute Nouveau
bonjour @gosselien
je vous transmets les deux fichiers Excel (les info ne sans pas correct :p juste pour faire le test )
le fichier IC ==> mon fichier A
le fichier piste ==> mon fichier B
je compare A et B ( colonne de comparaison nom,prénom)
si je trouve pas le nom, prénom de mon fichier A dans le fichier B je rajoute les informations en commun (non prénom TU , BM ..) dans mon fichier B.
je pense que c'est un peu difficile puisque les deux fichiers non pas la même structure ..
 

Pièces jointes

  • test_comparaison.zip
    168 bytes · Affichages: 54

vgendron

XLDnaute Barbatruc
Bonjour

essaie avec ce code à mettre dans un module VBA
VB:
Sub fusion()
Dim DataSource(), DataDest()
Set FicSource = Workbooks("IC.xlsx")
Set ficDest = Workbooks("Piste.xlsx")

TailleSource = FicSource.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
TailleDest = ficDest.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

ReDim DataSource(TailleSource, 22)
ReDim DataDest(TailleDest, 16) '= FicDest.Sheets("Sheet1").Range("A2:V" & Range("A" & Rows.Count).End(xlUp).Row).Value

DataSource = FicSource.Sheets("Sheet1").Range("A2:V" & Range("A" & Rows.Count).End(xlUp).Row).Value

For i = LBound(DataSource) To UBound(DataSource) ' nomPrenom In DataSource.Column(5).Value  ' = LBound(DataSource) To UBound(DataSource)
    For j = LBound(DataDest) + 1 To UBound(DataDest)
        If DataDest(j, 3) = DataSource(i, 5) Then
            trouve = True
        End If
    Next j
        If trouve = False Then
            NewTaille = UBound(DataDest) + 1
            ReDim DataDest(NewTaille, 16)
            DataDest(NewTaille, 1) = ""
            DataDest(NewTaille, 2) = DataSource(i, 2)
            DataDest(NewTaille, 3) = DataSource(i, 5)
            DataDest(NewTaille, 4) = DataSource(i, 9)
            DataDest(NewTaille, 5) = DataSource(i, 2)
            DataDest(NewTaille, 6) = DataSource(i, 18)
            DataDest(NewTaille, 7) = DataSource(i, 8)
            DataDest(NewTaille, 8) = DataSource(i, 13)
            DataDest(NewTaille, 9) = ""
            DataDest(NewTaille, 10) = DataSource(i, 4)
            DataDest(NewTaille, 11) = DataSource(i, 3)
            DataDest(NewTaille, 12) = DataSource(i, 17)
            DataDest(NewTaille, 13) = ""
            DataDest(NewTaille, 14) = ""
            DataDest(NewTaille, 15) = ""
            DataDest(NewTaille, 16) = "" 
        End If

Next i

For i = LBound(DataDest) To UBound(DataDest)
    For j = 1 To 16
        ficDest.Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, j - 1) = DataDest(i, j)
    Next j
Next i
End Sub
 

MELL90

XLDnaute Nouveau
@vgendron

Un grand merci pour votre retour ,

j'ai essayé le code mais j'ai le message d'erreur suivant:
"erreur d'exécution 9, l'indice n'appartient pas à la sélection"
la ligne d'erreur :
ficDest.Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, j - 1) = DataDest(i, j)

merci pour votre aide .
 

vgendron

XLDnaute Barbatruc
oui.. pardon..
j'aurais du préciser.
les deux fichiers doivent etre ouverts
il faut modifier le code pour que les noms de fichier correspondent -->IC.xlsx qui a été renommé IC.xlsm (pour fichier avec macro)
ainsi que les noms de feuilles: je travaillais avec une feuille test Sheet2--> il faut donc repasser avec Sheet1
ce qui donne
VB:
Sub fusion()
Dim DataSource(), DataDest()
Set FicSource = Workbooks("IC.xlsm")
Set ficDest = Workbooks("Piste.xlsx")

TailleSource = FicSource.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
TailleDest = ficDest.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

ReDim DataSource(TailleSource, 22)
ReDim DataDest(TailleDest, 16) '= FicDest.Sheets("Sheet1").Range("A2:V" & Range("A" & Rows.Count).End(xlUp).Row).Value

DataSource = FicSource.Sheets("Sheet1").Range("A2:V" & Range("A" & Rows.Count).End(xlUp).Row).Value

For i = LBound(DataSource) To UBound(DataSource) ' nomPrenom In DataSource.Column(5).Value  ' = LBound(DataSource) To UBound(DataSource)
    For j = LBound(DataDest) + 1 To UBound(DataDest)
        If DataDest(j, 3) = DataSource(i, 5) Then
            trouve = True
        End If
    Next j
        If trouve = False Then
            NewTaille = UBound(DataDest) + 1
            ReDim DataDest(NewTaille, 16)
            DataDest(NewTaille, 1) = ""
            DataDest(NewTaille, 2) = DataSource(i, 2)
            DataDest(NewTaille, 3) = DataSource(i, 5)
            DataDest(NewTaille, 4) = DataSource(i, 9)
            DataDest(NewTaille, 5) = DataSource(i, 2)
            DataDest(NewTaille, 6) = DataSource(i, 18)
            DataDest(NewTaille, 7) = DataSource(i, 8)
            DataDest(NewTaille, 8) = DataSource(i, 13)
            DataDest(NewTaille, 9) = ""
            DataDest(NewTaille, 10) = DataSource(i, 4)
            DataDest(NewTaille, 11) = DataSource(i, 3)
            DataDest(NewTaille, 12) = DataSource(i, 17)
            DataDest(NewTaille, 13) = ""
            DataDest(NewTaille, 14) = ""
            DataDest(NewTaille, 15) = ""
            DataDest(NewTaille, 16) = ""
        End If
Next i

For i = LBound(DataDest) To UBound(DataDest)
    For j = 1 To 16
        ficDest.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, j - 1) = DataDest(i, j)
    Next j
Next i
End Sub
à mettre dans un module dans le fichier IC.xlsm
 

vgendron

XLDnaute Barbatruc
et si. il y a un interet à avoir plus de 1 ligne..
ca permet de tester les boucles qui commencent à 1 ou 0..
dans une boucle. c'est presque toujours la première (ou dernière) itération qui bug..
donc la. je ne saurais pas te dire si, dans le cas de plusieurs lignes, ca fonctionne bien pour le tablo entier
 

vgendron

XLDnaute Barbatruc
Avec ceci. ca devrait aller mieux..
VB:
Sub fusion()
Dim DataSource(), DataDest()
Set FicSource = Workbooks("IC.xlsm")
Set FicDest = Workbooks("Piste.xlsx")

TailleSource = FicSource.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
TailleDest = FicDest.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Dim ListToCopy(1, 16) 'ligne à recopier

ReDim DataSource(TailleSource + 1, 22) 'contient la ligne d'entete
ReDim DataDest(TailleDest, 16) 'Contient la ligne à copier

DataSource = FicSource.Sheets("Sheet1").Range("A1:V" & TailleSource).Value
DataDest = FicDest.Sheets("Sheet1").Range("A1:P" & TailleDest).Value

For i = LBound(DataSource) + 1 To UBound(DataSource)
    For j = LBound(DataDest) + 1 To UBound(DataDest)
        If DataDest(j, 3) = DataSource(2, 5) Then 'on cherche le Nom Prénom
            trouve = True
        End If
    Next j
        If trouve = False Then 'si on a pas trouvé - on récupère les données de la ligne
            'NewTaille = UBound(DataDest) + 1
            'ReDim DataDest(NewTaille, 16)
            ListToCopy(1, 1) = "-" 'BU 'on met un - pour éviter d'écraser la dernière ligne au fur et à mesure
            ListToCopy(1, 2) = DataSource(i, 2) 'TU
            ListToCopy(1, 3) = DataSource(i, 5) 'Nom Prénom
            ListToCopy(1, 4) = DataSource(i, 9) 'Métier
            ListToCopy(1, 5) = DataSource(i, 2) 'TU
            ListToCopy(1, 6) = DataSource(i, 18) 'Date Dispo
            ListToCopy(1, 7) = DataSource(i, 8) 'DC OK
            ListToCopy(1, 8) = DataSource(i, 13) 'PPT OK
            ListToCopy(1, 9) = DataSource(i, 20) 'Salaire
            ListToCopy(1, 10) = DataSource(i, 4) 'BM
            ListToCopy(1, 11) = DataSource(i, 3) 'TM
            ListToCopy(1, 12) = DataSource(i, 17) 'Client
            ListToCopy(1, 13) = "" 'BM/TM
            ListToCopy(1, 14) = "" 'Date Dernier Statut
            ListToCopy(1, 15) = "" 'Etat
            ListToCopy(1, 16) = "" 'Action complémentaire
           
            FicDest.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = ListToCopy(1, 1)
            For k = 2 To 16
                    FicDest.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(0, k - 1) = ListToCopy(1, k)
            Next k
        End If
Next i
End Sub

Tu disais quoi sur l'utilité de plusieurs lignes?? :-D
 

MELL90

XLDnaute Nouveau
le nouveau code marche parfaitement juste je dois l'appliquer sur mes fichiers sources avec quelque modification ...
J'ai pas compris ta demande concernant la ligne je suis désolé :( si tu peux m'expliquer ...
par contre je sais pas si tu parles lors de l'ajout d' une ligne dans le fichier IC en temps réelle, dans ce cas je rencontre un problème ..
la mise à jour ne s'effectue pas directement je dois supprimer la totalité des lignes et exécuter le code .
 

MELL90

XLDnaute Nouveau
@vgendron Bonjour,
j’espère que ne vous dérange pas ... j'ai testé le code sur mes fichiers d'origine , il fonctionne bien mais il me reste le problème de la mise à jour, lorsque je rajoute une ligne ou je supprime une ligne de fichier IC rien ne change dans mon fichier piste . je dois à chaque fois effacer les enceignent lignes rajoutées .
merci pour votre aide .
 

Discussions similaires