comparer 2 fichiers 40 fois

Le
daniel
Bonjour,
J'ai un collègue qui rencontre un gros problème.
Il doit comparer 2 jeux (qui devraient être identiques) de 40 fichiers
chacun, pour déceler les éventuelles différences.
Chaque fichier a un nombre d'onglets et de cellules différents.
J'ai regardé dans les anciens messages, et j'ai essayé de testé quelques
exemples, mais je me plante très vite.
Merci de vos prochaines réponses.
DanielH
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Daniel.C
Le #21236121
Bonjour.
Loin d'être complet ni testé; les macros suivantes comparent deux
fichiers, Compar1.xlsm et Compar2.xlsm et notent les différences sur la
feuille "Différences" du classeur contenant la macro. Il reste à
ajouter une boucle pour ouvrir les paires de fichiers. Note que dans sa
version actuelle, le code considère que chaque feuille commence en
ligne 1 et en colonne 1. On peut adapter.

- la macro Compar ouvre et ferme les paires de fichiers, appelle la
macro comparant les feuilles :
- ComparFeuilles compare les feuilles et appele la macro
- ComparCellules qui fait la comparaison cellule par cellule.

Public Ligne As Long

Sub Compar()
Dim Fich1 As Workbook, Fich2 As Workbook
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Différences")
Workbooks.Open "Compar1.xlsm"
Workbooks.Open "Compar2.xlsm"
Set Fich1 = Workbooks("Compar1.xlsm")
Set Fich2 = Workbooks("Compar2.xlsm")
Ligne = 0
ComparFeuilles Fich1, Fich2, sh
Workbooks("Compar1.xlsm").Close False
Workbooks("Compar2.xlsm").Close False
End Sub

Sub ComparFeuilles(f1 As Workbook, f2 As Workbook, sh As Worksheet)
Dim f As Worksheet
On Error Resume Next
With sh
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Classeurs :"
.Cells(Ligne, 2) = f1.Name
.Cells(Ligne, 3) = f2.Name
For Each f In f1.Sheets
Set test = f2.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 2) = f.Name
.Cells(Ligne, 3) = "absente"
Else
Var = f1.f.Name
ComparCellules f1.Sheets(f.Name), f2.Sheets(f.Name), sh
End If
Next f
For Each f In f2.Sheets
Set test = f1.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 3) = f.Name
.Cells(Ligne, 2) = "absente"
End If
Next f
End With
On Error GoTo 0
End Sub

Sub ComparCellules(f1 As Worksheet, f2 As Worksheet, sh As Worksheet)
Dim h As Long, l As Integer, c As Range
h = Application.Max(f1.UsedRange.Rows.Count, f2.UsedRange.Rows.Count)
l = Application.Max(f1.UsedRange.Columns.Count,
f2.UsedRange.Columns.Count)
' implique que les deux feuilles commencent en ligne1 et en colonne 1
Var = Range(f1.Cells(1, 1), Cells(h, l))(1)
For Each c In Range(f1.Cells(1, 1), f1.Cells(h, l))
If c.Value <> f2.Range(c.Address) Then
Ligne = Ligne + 1
sh.Cells(Ligne, 1) = c.Address
sh.Cells(Ligne, 3) = f2.Range(c.Address).Value
sh.Cells(Ligne, 2) = c.Value
End If
Next c
End Sub

Le code n'est pas commenté dans un premier temps. Je reste à ta
disposition pour toute explication.

Daniel

Bonjour,
J'ai un collègue qui rencontre un gros problème.
Il doit comparer 2 jeux (qui devraient être identiques) de 40 fichiers
chacun, pour déceler les éventuelles différences.
Chaque fichier a un nombre d'onglets et de cellules différents.
J'ai regardé dans les anciens messages, et j'ai essayé de testé quelques
exemples, mais je me plante très vite.
Merci de vos prochaines réponses.
DanielH


daniel
Le #21237111
Bonjour,
Merci pour la réponse. Je regarde les macros, mais je me suis pas mal avancé
en trouvant d'autres modèles sur divers sites et je suis pas mal avancé,
presque à la fin d'ailleurs. Je cherche juste comment indiqué la durée de la
macro dans un msgbox. Ce que j'arrive à faire pour l'instant est un message
: 0,111254.
Encore merci.
DanielH

Au cas où je colle le résultat de mes efforts ci-dessous :

Sub Compare2Fichiers()

Dim Plg1 As Range, Plg2 As Range
Dim nomF1 As String, nomF2 As String, s As String
Dim cc As Range
Dim i As Integer

Depart = Time 'Now
'Ce classeur
CeClasseur = ThisWorkbook.Name
Début = Workbooks(CeClasseur).Sheets("Liste
différences").Range("A10").Address
'Mise à blanc du résultat
If Range("B8") > 0 Then
Range("A10:E" & Range("a65000").End(xlUp).Row).ClearContents
End If
'Sélection avec commentaire
Commentaire = Workbooks(CeClasseur).Sheets("Liste
différences").Range("Comment")
'nomF1 = "Fichier1.xls": nomF2 = "Fichier2.xls" ' à adapter
nomF1 = Range("B1").Value: nomF2 = Range("B2").Value ' à adapter
' Détermine les plages Plg1 et Plg2
Compteur = 0

If Workbooks.Count > 1 And Range("B1") <> "" Then

For i = 1 To Workbooks(nomF1).Worksheets.Count

Set Plg1 = Workbooks(nomF1).Sheets(i).Cells(1, 1) ' A1 première feuille
Set Plg1 = Range(Plg1, Plg1.SpecialCells(xlLastCell)) 'modif pour dernière
cellule

Set Plg2 = Workbooks(nomF2).Sheets(i).Cells(1, 1) 'A1 première feuille
Set Plg2 = Range(Plg2, Plg2.SpecialCells(xlLastCell)) 'modif pour dernière
cellule

Feuille1 = Workbooks(nomF1).Sheets(i).Name
Feuille2 = Workbooks(nomF2).Sheets(i).Name

'MsgBox Plg2.Address

For Each cc In Plg1
If Not cc.HasFormula Then
If cc.Value <> Plg2.Range(cc.Address).Value Then
If Commentaire Then
'On Error Resume Next
cc.AddComment "Différent"
Plg2.Range(cc.Address).AddComment "Différent"
'Error = 0
End If
'on inscrit les références des fichiers
Range(Début).Select
Range(Début) = Workbooks(nomF1).Sheets(i).Name 'Feuille1
Range(Début).Offset(, 1) = Workbooks(nomF2).Sheets(i).Name
'Feuille2
Range(Début).Offset(, 2) = cc.Address
Range(Début).Offset(, 3) = cc.Value
Range(Début).Offset(, 4) = Plg2.Range(Michel.Address).Value
Début = Range(Début).Offset(1).Address
'pour compter le nombre de différences
Compteur = Compteur + 1
End If
End If
Next cc
Next i

MsgBox "il y a " & Compteur & "différences"
Fini = Now - Depart
MsgBox Fini
Else
MsgBox "Il n'y a qu'un classeur ouvert ou les noms en B1 et B2 ne sont pas
renseignés"
Fini = Time("00:00:00") - Depart
MsgBox Fini
End If
End Sub


"Daniel.C"
Bonjour.
Loin d'être complet ni testé; les macros suivantes comparent deux
fichiers, Compar1.xlsm et Compar2.xlsm et notent les différences sur la
feuille "Différences" du classeur contenant la macro. Il reste à ajouter
une boucle pour ouvrir les paires de fichiers. Note que dans sa version
actuelle, le code considère que chaque feuille commence en ligne 1 et en
colonne 1. On peut adapter.

- la macro Compar ouvre et ferme les paires de fichiers, appelle la macro
comparant les feuilles :
- ComparFeuilles compare les feuilles et appele la macro
- ComparCellules qui fait la comparaison cellule par cellule.

Public Ligne As Long

Sub Compar()
Dim Fich1 As Workbook, Fich2 As Workbook
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Différences")
Workbooks.Open "Compar1.xlsm"
Workbooks.Open "Compar2.xlsm"
Set Fich1 = Workbooks("Compar1.xlsm")
Set Fich2 = Workbooks("Compar2.xlsm")
Ligne = 0
ComparFeuilles Fich1, Fich2, sh
Workbooks("Compar1.xlsm").Close False
Workbooks("Compar2.xlsm").Close False
End Sub

Sub ComparFeuilles(f1 As Workbook, f2 As Workbook, sh As Worksheet)
Dim f As Worksheet
On Error Resume Next
With sh
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Classeurs :"
.Cells(Ligne, 2) = f1.Name
.Cells(Ligne, 3) = f2.Name
For Each f In f1.Sheets
Set test = f2.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 2) = f.Name
.Cells(Ligne, 3) = "absente"
Else
Var = f1.f.Name
ComparCellules f1.Sheets(f.Name), f2.Sheets(f.Name), sh
End If
Next f
For Each f In f2.Sheets
Set test = f1.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 3) = f.Name
.Cells(Ligne, 2) = "absente"
End If
Next f
End With
On Error GoTo 0
End Sub

Sub ComparCellules(f1 As Worksheet, f2 As Worksheet, sh As Worksheet)
Dim h As Long, l As Integer, c As Range
h = Application.Max(f1.UsedRange.Rows.Count, f2.UsedRange.Rows.Count)
l = Application.Max(f1.UsedRange.Columns.Count,
f2.UsedRange.Columns.Count)
' implique que les deux feuilles commencent en ligne1 et en colonne 1
Var = Range(f1.Cells(1, 1), Cells(h, l))(1)
For Each c In Range(f1.Cells(1, 1), f1.Cells(h, l))
If c.Value <> f2.Range(c.Address) Then
Ligne = Ligne + 1
sh.Cells(Ligne, 1) = c.Address
sh.Cells(Ligne, 3) = f2.Range(c.Address).Value
sh.Cells(Ligne, 2) = c.Value
End If
Next c
End Sub

Le code n'est pas commenté dans un premier temps. Je reste à ta
disposition pour toute explication.

Daniel

Bonjour,
J'ai un collègue qui rencontre un gros problème.
Il doit comparer 2 jeux (qui devraient être identiques) de 40 fichiers
chacun, pour déceler les éventuelles différences.
Chaque fichier a un nombre d'onglets et de cellules différents.
J'ai regardé dans les anciens messages, et j'ai essayé de testé quelques
exemples, mais je me plante très vite.
Merci de vos prochaines réponses.
DanielH






Daniel.C
Le #21237101
Regarde l'aide VBA sur "Timer"
Daniel

Bonjour,
Merci pour la réponse. Je regarde les macros, mais je me suis pas mal avancé
en trouvant d'autres modèles sur divers sites et je suis pas mal avancé,
presque à la fin d'ailleurs. Je cherche juste comment indiqué la durée de la
macro dans un msgbox. Ce que j'arrive à faire pour l'instant est un message
: 0,111254.
Encore merci.
DanielH

Au cas où je colle le résultat de mes efforts ci-dessous :

Sub Compare2Fichiers()

Dim Plg1 As Range, Plg2 As Range
Dim nomF1 As String, nomF2 As String, s As String
Dim cc As Range
Dim i As Integer

Depart = Time 'Now
'Ce classeur
CeClasseur = ThisWorkbook.Name
Début = Workbooks(CeClasseur).Sheets("Liste
différences").Range("A10").Address
'Mise à blanc du résultat
If Range("B8") > 0 Then
Range("A10:E" & Range("a65000").End(xlUp).Row).ClearContents
End If
'Sélection avec commentaire
Commentaire = Workbooks(CeClasseur).Sheets("Liste
différences").Range("Comment")
'nomF1 = "Fichier1.xls": nomF2 = "Fichier2.xls" ' à adapter
nomF1 = Range("B1").Value: nomF2 = Range("B2").Value ' à adapter
' Détermine les plages Plg1 et Plg2
Compteur = 0

If Workbooks.Count > 1 And Range("B1") <> "" Then

For i = 1 To Workbooks(nomF1).Worksheets.Count

Set Plg1 = Workbooks(nomF1).Sheets(i).Cells(1, 1) ' A1 première feuille
Set Plg1 = Range(Plg1, Plg1.SpecialCells(xlLastCell)) 'modif pour dernière
cellule

Set Plg2 = Workbooks(nomF2).Sheets(i).Cells(1, 1) 'A1 première feuille
Set Plg2 = Range(Plg2, Plg2.SpecialCells(xlLastCell)) 'modif pour dernière
cellule

Feuille1 = Workbooks(nomF1).Sheets(i).Name
Feuille2 = Workbooks(nomF2).Sheets(i).Name

'MsgBox Plg2.Address

For Each cc In Plg1
If Not cc.HasFormula Then
If cc.Value <> Plg2.Range(cc.Address).Value Then
If Commentaire Then
'On Error Resume Next
cc.AddComment "Différent"
Plg2.Range(cc.Address).AddComment "Différent"
'Error = 0
End If
'on inscrit les références des fichiers
Range(Début).Select
Range(Début) = Workbooks(nomF1).Sheets(i).Name 'Feuille1
Range(Début).Offset(, 1) = Workbooks(nomF2).Sheets(i).Name 'Feuille2
Range(Début).Offset(, 2) = cc.Address
Range(Début).Offset(, 3) = cc.Value
Range(Début).Offset(, 4) = Plg2.Range(Michel.Address).Value
Début = Range(Début).Offset(1).Address
'pour compter le nombre de différences
Compteur = Compteur + 1
End If
End If
Next cc
Next i

MsgBox "il y a " & Compteur & "différences"
Fini = Now - Depart
MsgBox Fini
Else
MsgBox "Il n'y a qu'un classeur ouvert ou les noms en B1 et B2 ne sont pas
renseignés"
Fini = Time("00:00:00") - Depart
MsgBox Fini
End If
End Sub


"Daniel.C"
Bonjour.
Loin d'être complet ni testé; les macros suivantes comparent deux fichiers,
Compar1.xlsm et Compar2.xlsm et notent les différences sur la feuille
"Différences" du classeur contenant la macro. Il reste à ajouter une boucle
pour ouvrir les paires de fichiers. Note que dans sa version actuelle, le
code considère que chaque feuille commence en ligne 1 et en colonne 1. On
peut adapter.

- la macro Compar ouvre et ferme les paires de fichiers, appelle la macro
comparant les feuilles :
- ComparFeuilles compare les feuilles et appele la macro
- ComparCellules qui fait la comparaison cellule par cellule.

Public Ligne As Long

Sub Compar()
Dim Fich1 As Workbook, Fich2 As Workbook
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Différences")
Workbooks.Open "Compar1.xlsm"
Workbooks.Open "Compar2.xlsm"
Set Fich1 = Workbooks("Compar1.xlsm")
Set Fich2 = Workbooks("Compar2.xlsm")
Ligne = 0
ComparFeuilles Fich1, Fich2, sh
Workbooks("Compar1.xlsm").Close False
Workbooks("Compar2.xlsm").Close False
End Sub

Sub ComparFeuilles(f1 As Workbook, f2 As Workbook, sh As Worksheet)
Dim f As Worksheet
On Error Resume Next
With sh
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Classeurs :"
.Cells(Ligne, 2) = f1.Name
.Cells(Ligne, 3) = f2.Name
For Each f In f1.Sheets
Set test = f2.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 2) = f.Name
.Cells(Ligne, 3) = "absente"
Else
Var = f1.f.Name
ComparCellules f1.Sheets(f.Name), f2.Sheets(f.Name), sh
End If
Next f
For Each f In f2.Sheets
Set test = f1.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 3) = f.Name
.Cells(Ligne, 2) = "absente"
End If
Next f
End With
On Error GoTo 0
End Sub

Sub ComparCellules(f1 As Worksheet, f2 As Worksheet, sh As Worksheet)
Dim h As Long, l As Integer, c As Range
h = Application.Max(f1.UsedRange.Rows.Count, f2.UsedRange.Rows.Count)
l = Application.Max(f1.UsedRange.Columns.Count, f2.UsedRange.Columns.Count)
' implique que les deux feuilles commencent en ligne1 et en colonne 1
Var = Range(f1.Cells(1, 1), Cells(h, l))(1)
For Each c In Range(f1.Cells(1, 1), f1.Cells(h, l))
If c.Value <> f2.Range(c.Address) Then
Ligne = Ligne + 1
sh.Cells(Ligne, 1) = c.Address
sh.Cells(Ligne, 3) = f2.Range(c.Address).Value
sh.Cells(Ligne, 2) = c.Value
End If
Next c
End Sub

Le code n'est pas commenté dans un premier temps. Je reste à ta disposition
pour toute explication.

Daniel

Bonjour,
J'ai un collègue qui rencontre un gros problème.
Il doit comparer 2 jeux (qui devraient être identiques) de 40 fichiers
chacun, pour déceler les éventuelles différences.
Chaque fichier a un nombre d'onglets et de cellules différents.
J'ai regardé dans les anciens messages, et j'ai essayé de testé quelques
exemples, mais je me plante très vite.
Merci de vos prochaines réponses.
DanielH








daniel
Le #21237201
Je viens de regarder, mais toujours pareil, le format est moche 1,2322
Il faut sûrement le mettre en format, mais je ne trouve pas pour l'instant
DanielH

"Daniel.C" %
Regarde l'aide VBA sur "Timer"
Daniel

Bonjour,
Merci pour la réponse. Je regarde les macros, mais je me suis pas mal
avancé en trouvant d'autres modèles sur divers sites et je suis pas mal
avancé, presque à la fin d'ailleurs. Je cherche juste comment indiqué la
durée de la macro dans un msgbox. Ce que j'arrive à faire pour l'instant
est un message
: 0,111254.
Encore merci.
DanielH

Au cas où je colle le résultat de mes efforts ci-dessous :

Sub Compare2Fichiers()

Dim Plg1 As Range, Plg2 As Range
Dim nomF1 As String, nomF2 As String, s As String
Dim cc As Range
Dim i As Integer

Depart = Time 'Now
'Ce classeur
CeClasseur = ThisWorkbook.Name
Début = Workbooks(CeClasseur).Sheets("Liste
différences").Range("A10").Address
'Mise à blanc du résultat
If Range("B8") > 0 Then
Range("A10:E" & Range("a65000").End(xlUp).Row).ClearContents
End If
'Sélection avec commentaire
Commentaire = Workbooks(CeClasseur).Sheets("Liste
différences").Range("Comment")
'nomF1 = "Fichier1.xls": nomF2 = "Fichier2.xls" ' à adapter
nomF1 = Range("B1").Value: nomF2 = Range("B2").Value ' à adapter
' Détermine les plages Plg1 et Plg2
Compteur = 0

If Workbooks.Count > 1 And Range("B1") <> "" Then

For i = 1 To Workbooks(nomF1).Worksheets.Count

Set Plg1 = Workbooks(nomF1).Sheets(i).Cells(1, 1) ' A1 première feuille
Set Plg1 = Range(Plg1, Plg1.SpecialCells(xlLastCell)) 'modif pour
dernière cellule

Set Plg2 = Workbooks(nomF2).Sheets(i).Cells(1, 1) 'A1 première feuille
Set Plg2 = Range(Plg2, Plg2.SpecialCells(xlLastCell)) 'modif pour
dernière cellule

Feuille1 = Workbooks(nomF1).Sheets(i).Name
Feuille2 = Workbooks(nomF2).Sheets(i).Name

'MsgBox Plg2.Address

For Each cc In Plg1
If Not cc.HasFormula Then
If cc.Value <> Plg2.Range(cc.Address).Value Then
If Commentaire Then
'On Error Resume Next
cc.AddComment "Différent"
Plg2.Range(cc.Address).AddComment "Différent"
'Error = 0
End If
'on inscrit les références des fichiers
Range(Début).Select
Range(Début) = Workbooks(nomF1).Sheets(i).Name 'Feuille1
Range(Début).Offset(, 1) = Workbooks(nomF2).Sheets(i).Name
'Feuille2
Range(Début).Offset(, 2) = cc.Address
Range(Début).Offset(, 3) = cc.Value
Range(Début).Offset(, 4) = Plg2.Range(Michel.Address).Value
Début = Range(Début).Offset(1).Address
'pour compter le nombre de différences
Compteur = Compteur + 1
End If
End If
Next cc
Next i

MsgBox "il y a " & Compteur & "différences"
Fini = Now - Depart
MsgBox Fini
Else
MsgBox "Il n'y a qu'un classeur ouvert ou les noms en B1 et B2 ne sont
pas renseignés"
Fini = Time("00:00:00") - Depart
MsgBox Fini
End If
End Sub


"Daniel.C"
Bonjour.
Loin d'être complet ni testé; les macros suivantes comparent deux
fichiers, Compar1.xlsm et Compar2.xlsm et notent les différences sur la
feuille "Différences" du classeur contenant la macro. Il reste à ajouter
une boucle pour ouvrir les paires de fichiers. Note que dans sa version
actuelle, le code considère que chaque feuille commence en ligne 1 et en
colonne 1. On peut adapter.

- la macro Compar ouvre et ferme les paires de fichiers, appelle la
macro comparant les feuilles :
- ComparFeuilles compare les feuilles et appele la macro
- ComparCellules qui fait la comparaison cellule par cellule.

Public Ligne As Long

Sub Compar()
Dim Fich1 As Workbook, Fich2 As Workbook
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Différences")
Workbooks.Open "Compar1.xlsm"
Workbooks.Open "Compar2.xlsm"
Set Fich1 = Workbooks("Compar1.xlsm")
Set Fich2 = Workbooks("Compar2.xlsm")
Ligne = 0
ComparFeuilles Fich1, Fich2, sh
Workbooks("Compar1.xlsm").Close False
Workbooks("Compar2.xlsm").Close False
End Sub

Sub ComparFeuilles(f1 As Workbook, f2 As Workbook, sh As Worksheet)
Dim f As Worksheet
On Error Resume Next
With sh
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Classeurs :"
.Cells(Ligne, 2) = f1.Name
.Cells(Ligne, 3) = f2.Name
For Each f In f1.Sheets
Set test = f2.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 2) = f.Name
.Cells(Ligne, 3) = "absente"
Else
Var = f1.f.Name
ComparCellules f1.Sheets(f.Name), f2.Sheets(f.Name), sh
End If
Next f
For Each f In f2.Sheets
Set test = f1.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 3) = f.Name
.Cells(Ligne, 2) = "absente"
End If
Next f
End With
On Error GoTo 0
End Sub

Sub ComparCellules(f1 As Worksheet, f2 As Worksheet, sh As Worksheet)
Dim h As Long, l As Integer, c As Range
h = Application.Max(f1.UsedRange.Rows.Count, f2.UsedRange.Rows.Count)
l = Application.Max(f1.UsedRange.Columns.Count,
f2.UsedRange.Columns.Count)
' implique que les deux feuilles commencent en ligne1 et en colonne 1
Var = Range(f1.Cells(1, 1), Cells(h, l))(1)
For Each c In Range(f1.Cells(1, 1), f1.Cells(h, l))
If c.Value <> f2.Range(c.Address) Then
Ligne = Ligne + 1
sh.Cells(Ligne, 1) = c.Address
sh.Cells(Ligne, 3) = f2.Range(c.Address).Value
sh.Cells(Ligne, 2) = c.Value
End If
Next c
End Sub

Le code n'est pas commenté dans un premier temps. Je reste à ta
disposition pour toute explication.

Daniel

Bonjour,
J'ai un collègue qui rencontre un gros problème.
Il doit comparer 2 jeux (qui devraient être identiques) de 40 fichiers
chacun, pour déceler les éventuelles différences.
Chaque fichier a un nombre d'onglets et de cellules différents.
J'ai regardé dans les anciens messages, et j'ai essayé de testé
quelques exemples, mais je me plante très vite.
Merci de vos prochaines réponses.
DanielH












Daniel.C
Le #21237311
MsgBox Format(debut, "mm:ss")
Daniel

Je viens de regarder, mais toujours pareil, le format est moche 1,2322
Il faut sûrement le mettre en format, mais je ne trouve pas pour l'instant
DanielH

"Daniel.C" %
Regarde l'aide VBA sur "Timer"
Daniel

Bonjour,
Merci pour la réponse. Je regarde les macros, mais je me suis pas mal
avancé en trouvant d'autres modèles sur divers sites et je suis pas mal
avancé, presque à la fin d'ailleurs. Je cherche juste comment indiqué la
durée de la macro dans un msgbox. Ce que j'arrive à faire pour l'instant
est un message
: 0,111254.
Encore merci.
DanielH

Au cas où je colle le résultat de mes efforts ci-dessous :

Sub Compare2Fichiers()

Dim Plg1 As Range, Plg2 As Range
Dim nomF1 As String, nomF2 As String, s As String
Dim cc As Range
Dim i As Integer

Depart = Time 'Now
'Ce classeur
CeClasseur = ThisWorkbook.Name
Début = Workbooks(CeClasseur).Sheets("Liste
différences").Range("A10").Address
'Mise à blanc du résultat
If Range("B8") > 0 Then
Range("A10:E" & Range("a65000").End(xlUp).Row).ClearContents
End If
'Sélection avec commentaire
Commentaire = Workbooks(CeClasseur).Sheets("Liste
différences").Range("Comment")
'nomF1 = "Fichier1.xls": nomF2 = "Fichier2.xls" ' à adapter
nomF1 = Range("B1").Value: nomF2 = Range("B2").Value ' à adapter
' Détermine les plages Plg1 et Plg2
Compteur = 0

If Workbooks.Count > 1 And Range("B1") <> "" Then

For i = 1 To Workbooks(nomF1).Worksheets.Count

Set Plg1 = Workbooks(nomF1).Sheets(i).Cells(1, 1) ' A1 première feuille
Set Plg1 = Range(Plg1, Plg1.SpecialCells(xlLastCell)) 'modif pour
dernière cellule

Set Plg2 = Workbooks(nomF2).Sheets(i).Cells(1, 1) 'A1 première feuille
Set Plg2 = Range(Plg2, Plg2.SpecialCells(xlLastCell)) 'modif pour
dernière cellule

Feuille1 = Workbooks(nomF1).Sheets(i).Name
Feuille2 = Workbooks(nomF2).Sheets(i).Name

'MsgBox Plg2.Address

For Each cc In Plg1
If Not cc.HasFormula Then
If cc.Value <> Plg2.Range(cc.Address).Value Then
If Commentaire Then
'On Error Resume Next
cc.AddComment "Différent"
Plg2.Range(cc.Address).AddComment "Différent"
'Error = 0
End If
'on inscrit les références des fichiers
Range(Début).Select
Range(Début) = Workbooks(nomF1).Sheets(i).Name 'Feuille1
Range(Début).Offset(, 1) = Workbooks(nomF2).Sheets(i).Name
'Feuille2
Range(Début).Offset(, 2) = cc.Address
Range(Début).Offset(, 3) = cc.Value
Range(Début).Offset(, 4) = Plg2.Range(Michel.Address).Value
Début = Range(Début).Offset(1).Address
'pour compter le nombre de différences
Compteur = Compteur + 1
End If
End If
Next cc
Next i

MsgBox "il y a " & Compteur & "différences"
Fini = Now - Depart
MsgBox Fini
Else
MsgBox "Il n'y a qu'un classeur ouvert ou les noms en B1 et B2 ne sont pas
renseignés"
Fini = Time("00:00:00") - Depart
MsgBox Fini
End If
End Sub


"Daniel.C"
Bonjour.
Loin d'être complet ni testé; les macros suivantes comparent deux
fichiers, Compar1.xlsm et Compar2.xlsm et notent les différences sur la
feuille "Différences" du classeur contenant la macro. Il reste à ajouter
une boucle pour ouvrir les paires de fichiers. Note que dans sa version
actuelle, le code considère que chaque feuille commence en ligne 1 et en
colonne 1. On peut adapter.

- la macro Compar ouvre et ferme les paires de fichiers, appelle la macro
comparant les feuilles :
- ComparFeuilles compare les feuilles et appele la macro
- ComparCellules qui fait la comparaison cellule par cellule.

Public Ligne As Long

Sub Compar()
Dim Fich1 As Workbook, Fich2 As Workbook
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Différences")
Workbooks.Open "Compar1.xlsm"
Workbooks.Open "Compar2.xlsm"
Set Fich1 = Workbooks("Compar1.xlsm")
Set Fich2 = Workbooks("Compar2.xlsm")
Ligne = 0
ComparFeuilles Fich1, Fich2, sh
Workbooks("Compar1.xlsm").Close False
Workbooks("Compar2.xlsm").Close False
End Sub

Sub ComparFeuilles(f1 As Workbook, f2 As Workbook, sh As Worksheet)
Dim f As Worksheet
On Error Resume Next
With sh
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Classeurs :"
.Cells(Ligne, 2) = f1.Name
.Cells(Ligne, 3) = f2.Name
For Each f In f1.Sheets
Set test = f2.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 2) = f.Name
.Cells(Ligne, 3) = "absente"
Else
Var = f1.f.Name
ComparCellules f1.Sheets(f.Name), f2.Sheets(f.Name), sh
End If
Next f
For Each f In f2.Sheets
Set test = f1.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 3) = f.Name
.Cells(Ligne, 2) = "absente"
End If
Next f
End With
On Error GoTo 0
End Sub

Sub ComparCellules(f1 As Worksheet, f2 As Worksheet, sh As Worksheet)
Dim h As Long, l As Integer, c As Range
h = Application.Max(f1.UsedRange.Rows.Count, f2.UsedRange.Rows.Count)
l = Application.Max(f1.UsedRange.Columns.Count,
f2.UsedRange.Columns.Count)
' implique que les deux feuilles commencent en ligne1 et en colonne 1
Var = Range(f1.Cells(1, 1), Cells(h, l))(1)
For Each c In Range(f1.Cells(1, 1), f1.Cells(h, l))
If c.Value <> f2.Range(c.Address) Then
Ligne = Ligne + 1
sh.Cells(Ligne, 1) = c.Address
sh.Cells(Ligne, 3) = f2.Range(c.Address).Value
sh.Cells(Ligne, 2) = c.Value
End If
Next c
End Sub

Le code n'est pas commenté dans un premier temps. Je reste à ta
disposition pour toute explication.

Daniel

Bonjour,
J'ai un collègue qui rencontre un gros problème.
Il doit comparer 2 jeux (qui devraient être identiques) de 40 fichiers
chacun, pour déceler les éventuelles différences.
Chaque fichier a un nombre d'onglets et de cellules différents.
J'ai regardé dans les anciens messages, et j'ai essayé de testé quelques
exemples, mais je me plante très vite.
Merci de vos prochaines réponses.
DanielH














daniel
Le #21237291
Merci, et pourtant j'ai cherché.... mais mal.
Bonne soirée.
DanielH

"Daniel.C"
MsgBox Format(debut, "mm:ss")
Daniel

Je viens de regarder, mais toujours pareil, le format est moche 1,2322
Il faut sûrement le mettre en format, mais je ne trouve pas pour
l'instant
DanielH

"Daniel.C" %
Regarde l'aide VBA sur "Timer"
Daniel

Bonjour,
Merci pour la réponse. Je regarde les macros, mais je me suis pas mal
avancé en trouvant d'autres modèles sur divers sites et je suis pas mal
avancé, presque à la fin d'ailleurs. Je cherche juste comment indiqué
la durée de la macro dans un msgbox. Ce que j'arrive à faire pour
l'instant est un message
: 0,111254.
Encore merci.
DanielH

Au cas où je colle le résultat de mes efforts ci-dessous :

Sub Compare2Fichiers()

Dim Plg1 As Range, Plg2 As Range
Dim nomF1 As String, nomF2 As String, s As String
Dim cc As Range
Dim i As Integer

Depart = Time 'Now
'Ce classeur
CeClasseur = ThisWorkbook.Name
Début = Workbooks(CeClasseur).Sheets("Liste
différences").Range("A10").Address
'Mise à blanc du résultat
If Range("B8") > 0 Then
Range("A10:E" & Range("a65000").End(xlUp).Row).ClearContents
End If
'Sélection avec commentaire
Commentaire = Workbooks(CeClasseur).Sheets("Liste
différences").Range("Comment")
'nomF1 = "Fichier1.xls": nomF2 = "Fichier2.xls" ' à adapter
nomF1 = Range("B1").Value: nomF2 = Range("B2").Value ' à adapter
' Détermine les plages Plg1 et Plg2
Compteur = 0

If Workbooks.Count > 1 And Range("B1") <> "" Then

For i = 1 To Workbooks(nomF1).Worksheets.Count

Set Plg1 = Workbooks(nomF1).Sheets(i).Cells(1, 1) ' A1 première feuille
Set Plg1 = Range(Plg1, Plg1.SpecialCells(xlLastCell)) 'modif pour
dernière cellule

Set Plg2 = Workbooks(nomF2).Sheets(i).Cells(1, 1) 'A1 première
feuille
Set Plg2 = Range(Plg2, Plg2.SpecialCells(xlLastCell)) 'modif pour
dernière cellule

Feuille1 = Workbooks(nomF1).Sheets(i).Name
Feuille2 = Workbooks(nomF2).Sheets(i).Name

'MsgBox Plg2.Address

For Each cc In Plg1
If Not cc.HasFormula Then
If cc.Value <> Plg2.Range(cc.Address).Value Then
If Commentaire Then
'On Error Resume Next
cc.AddComment "Différent"
Plg2.Range(cc.Address).AddComment "Différent"
'Error = 0
End If
'on inscrit les références des fichiers
Range(Début).Select
Range(Début) = Workbooks(nomF1).Sheets(i).Name 'Feuille1
Range(Début).Offset(, 1) = Workbooks(nomF2).Sheets(i).Name
'Feuille2
Range(Début).Offset(, 2) = cc.Address
Range(Début).Offset(, 3) = cc.Value
Range(Début).Offset(, 4) = Plg2.Range(Michel.Address).Value
Début = Range(Début).Offset(1).Address
'pour compter le nombre de différences
Compteur = Compteur + 1
End If
End If
Next cc
Next i

MsgBox "il y a " & Compteur & "différences"
Fini = Now - Depart
MsgBox Fini
Else
MsgBox "Il n'y a qu'un classeur ouvert ou les noms en B1 et B2 ne sont
pas renseignés"
Fini = Time("00:00:00") - Depart
MsgBox Fini
End If
End Sub


"Daniel.C"
Bonjour.
Loin d'être complet ni testé; les macros suivantes comparent deux
fichiers, Compar1.xlsm et Compar2.xlsm et notent les différences sur
la feuille "Différences" du classeur contenant la macro. Il reste à
ajouter une boucle pour ouvrir les paires de fichiers. Note que dans
sa version actuelle, le code considère que chaque feuille commence en
ligne 1 et en colonne 1. On peut adapter.

- la macro Compar ouvre et ferme les paires de fichiers, appelle la
macro comparant les feuilles :
- ComparFeuilles compare les feuilles et appele la macro
- ComparCellules qui fait la comparaison cellule par cellule.

Public Ligne As Long

Sub Compar()
Dim Fich1 As Workbook, Fich2 As Workbook
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Différences")
Workbooks.Open "Compar1.xlsm"
Workbooks.Open "Compar2.xlsm"
Set Fich1 = Workbooks("Compar1.xlsm")
Set Fich2 = Workbooks("Compar2.xlsm")
Ligne = 0
ComparFeuilles Fich1, Fich2, sh
Workbooks("Compar1.xlsm").Close False
Workbooks("Compar2.xlsm").Close False
End Sub

Sub ComparFeuilles(f1 As Workbook, f2 As Workbook, sh As Worksheet)
Dim f As Worksheet
On Error Resume Next
With sh
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Classeurs :"
.Cells(Ligne, 2) = f1.Name
.Cells(Ligne, 3) = f2.Name
For Each f In f1.Sheets
Set test = f2.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 2) = f.Name
.Cells(Ligne, 3) = "absente"
Else
Var = f1.f.Name
ComparCellules f1.Sheets(f.Name), f2.Sheets(f.Name), sh
End If
Next f
For Each f In f2.Sheets
Set test = f1.Sheets(f.Name)
If Err.Number <> 0 Then
Err.Clear
Ligne = Ligne + 1
.Cells(Ligne, 1) = "Feuille"
.Cells(Ligne, 3) = f.Name
.Cells(Ligne, 2) = "absente"
End If
Next f
End With
On Error GoTo 0
End Sub

Sub ComparCellules(f1 As Worksheet, f2 As Worksheet, sh As Worksheet)
Dim h As Long, l As Integer, c As Range
h = Application.Max(f1.UsedRange.Rows.Count, f2.UsedRange.Rows.Count)
l = Application.Max(f1.UsedRange.Columns.Count,
f2.UsedRange.Columns.Count)
' implique que les deux feuilles commencent en ligne1 et en colonne 1
Var = Range(f1.Cells(1, 1), Cells(h, l))(1)
For Each c In Range(f1.Cells(1, 1), f1.Cells(h, l))
If c.Value <> f2.Range(c.Address) Then
Ligne = Ligne + 1
sh.Cells(Ligne, 1) = c.Address
sh.Cells(Ligne, 3) = f2.Range(c.Address).Value
sh.Cells(Ligne, 2) = c.Value
End If
Next c
End Sub

Le code n'est pas commenté dans un premier temps. Je reste à ta
disposition pour toute explication.

Daniel

Bonjour,
J'ai un collègue qui rencontre un gros problème.
Il doit comparer 2 jeux (qui devraient être identiques) de 40
fichiers chacun, pour déceler les éventuelles différences.
Chaque fichier a un nombre d'onglets et de cellules différents.
J'ai regardé dans les anciens messages, et j'ai essayé de testé
quelques exemples, mais je me plante très vite.
Merci de vos prochaines réponses.
DanielH


















Publicité
Poster une réponse
Anonyme