macro comparaison fichier ne fonctionne pas

Le
VASNIER
Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé les
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où est le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub



Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub


--
Pascale
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Michel Angelosanto
Le #5428511
Les classeurs sont ils gros ?
Quelle macro plante ? Les deux ?
Tes classeurs s'appellent bien classeur1.xls et classeur2.xls ?
Essaie en enlevant cette ligne, tu verras peut être ce qui se passe
d'anormal sinon execute en pas à pas en allant dans le code vba puis en
appuyant sur F8
Application.ScreenUpdating = False


"VASNIER" news:
Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé les
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où est
le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub



Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub


--
Pascale


--
Michel Angelosanto, Bordeaux
http://angelosa.free.fr/

VASNIER
Le #5428481
Bonsoir,

Merci pour ta réponse,

Les deux macros plantent, mes deux fichiers ont 2000 lignes à peu près
chacun et 10 colonnes. J'ai essayé d'enlever la ligne, c'est pareil, excel ne
répond pas

encore merci
--
Pascale



Les classeurs sont ils gros ?
Quelle macro plante ? Les deux ?
Tes classeurs s'appellent bien classeur1.xls et classeur2.xls ?
Essaie en enlevant cette ligne, tu verras peut être ce qui se passe
d'anormal sinon execute en pas à pas en allant dans le code vba puis en
appuyant sur F8
Application.ScreenUpdating = False


"VASNIER" news:
Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé les
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où est
le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub



Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub


--
Pascale


--
Michel Angelosanto, Bordeaux
http://angelosa.free.fr/





JB
Le #5428441
Bonsoir,

Sub ComparaisonColonne()
t = Timer()
f = 1 'no feuille
Application.ScreenUpdating = False
Set MonDico1 = CreateObject("Scripting.Dictionary")
Set MonDico2 = CreateObject("Scripting.Dictionary")
Workbooks("classeur1.xls").Activate
For Each c In
Sheets(f).Range("A:D").SpecialCells(xlCellTypeConstants, 23)
If Not MonDico1.Exists(c.Value) Then MonDico1.Add c.Value,
c.Address
Next
Workbooks("classeur2.xls").Activate
Sheets(f).Activate
For Each c In
Sheets(f).Range("A:D").SpecialCells(xlCellTypeConstants, 23)
If Not MonDico2.Exists(c.Value) Then MonDico2.Add c.Value,
c.Address
Next

Workbooks("classeur1.xls").Activate
Sheets(f).Activate
For Each e In MonDico1
If Not MonDico2.Exists(e) Then
Range(MonDico1.Item(e)).Font.Color = vbRed
Else
Range(MonDico1.Item(e)).Font.Color = vbBlack
End If
Next
Application.ScreenUpdating = True
MsgBox Timer() - t
End Sub

http://cjoint.com/?dEtxJVKHKZ

JB
http://boisgontierjacques.free.fr/


On 30 mar, 15:36, VASNIER
Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé les  
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où e st le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

--
Pascale


VASNIER
Le #5428431
Merci beaucoup je vais essayer la solution de JB
Bonne soirée
--
Pascale



Bonsoir,

Sub ComparaisonColonne()
t = Timer()
f = 1 'no feuille
Application.ScreenUpdating = False
Set MonDico1 = CreateObject("Scripting.Dictionary")
Set MonDico2 = CreateObject("Scripting.Dictionary")
Workbooks("classeur1.xls").Activate
For Each c In
Sheets(f).Range("A:D").SpecialCells(xlCellTypeConstants, 23)
If Not MonDico1.Exists(c.Value) Then MonDico1.Add c.Value,
c.Address
Next
Workbooks("classeur2.xls").Activate
Sheets(f).Activate
For Each c In
Sheets(f).Range("A:D").SpecialCells(xlCellTypeConstants, 23)
If Not MonDico2.Exists(c.Value) Then MonDico2.Add c.Value,
c.Address
Next

Workbooks("classeur1.xls").Activate
Sheets(f).Activate
For Each e In MonDico1
If Not MonDico2.Exists(e) Then
Range(MonDico1.Item(e)).Font.Color = vbRed
Else
Range(MonDico1.Item(e)).Font.Color = vbBlack
End If
Next
Application.ScreenUpdating = True
MsgBox Timer() - t
End Sub

http://cjoint.com/?dEtxJVKHKZ

JB
http://boisgontierjacques.free.fr/


On 30 mar, 15:36, VASNIER
Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé les
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où est le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

--
Pascale






Fredo P.
Le #5428391
Sub BpplusRap()
Dim c As Object, t
Dim plg1 As Range, Plg2 As Range
Application.ScreenUpdating = False
t = Timer()
'Workbooks("classeur1.xls").Activate
Set plg1 = Workbooks("Classeur1.xls").Sheets("Feuil1").Range("A1:A100")
'Workbooks("classeur2.xls").Activate
Set Plg2 = Workbooks("Classeur2.xls").Sheets("Feuil1").Range("A1:A100")
For Each c In plg1
If Plg2.Find(c) Is Nothing Then
c.Font.Bold = True
Else
c.Font.Bold = False
End If
Next
MsgBox Timer() - t
Application.ScreenUpdating = True
End Sub
--

Sans les bérouettes
"VASNIER"
Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé les
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où est
le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub



Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub


--
Pascale


JB
Le #5428371
Bonjour,

Pour 10.000 éléments 2,3s au lieu de 17,5 s

Sub ComparaisonChamp()
t = Timer()
Application.ScreenUpdating = False
Set MonDico1 = CreateObject("Scripting.Dictionary")
Set MonDico2 = CreateObject("Scripting.Dictionary")
Workbooks("classeur1.xls").Activate
For Each c In
Sheets(1).Range("A1:B5000").SpecialCells(xlCellTypeConstants, 23)
If Not MonDico1.Exists(c.Value) Then MonDico1.Add c.Value,
c.Address
Next
Workbooks("classeur2.xls").Activate
For Each c In Sheets(1).Range("A1:B5000")
If Not MonDico2.Exists(c) Then MonDico2.Add c.Value, c.Address
Next
Workbooks("classeur1.xls").Activate
For Each e In MonDico1
Range(MonDico1.Item(e)).Font.Color = IIf(MonDico2.Exists(e),
vblack, vbRed)
Next
MsgBox Timer() - t
End Sub

JB

On 31 mar, 00:11, "Fredo P."
Sub BpplusRap()
Dim c As Object, t
Dim plg1 As Range, Plg2 As Range
Application.ScreenUpdating = False
t = Timer()
'Workbooks("classeur1.xls").Activate
Set plg1 = Workbooks("Classeur1.xls").Sheets("Feuil1").Range("A1:A100")
'Workbooks("classeur2.xls").Activate
Set Plg2 = Workbooks("Classeur2.xls").Sheets("Feuil1").Range("A1:A100")
For Each c In plg1
If Plg2.Find(c) Is Nothing Then
c.Font.Bold = True
Else
c.Font.Bold = False
End If
Next
MsgBox Timer() - t
Application.ScreenUpdating = True
End Sub
--

Sans les bérouettes
"VASNIER"



Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé le s
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où est
le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

--
Pascale- Masquer le texte des messages précédents -


- Afficher le texte des messages précédents -



Fredo P.
Le #5427891
Bonsoir JB
J'ai effectué qqn essais pour en avoir le cour net. Sur plages> 450
cellules, ComparaisonChamp est sans conteste plus rapide d'autant plus que
la plage est importante, par contre c'est moins bon pour les plages
inférieures.

Tchüss
--



Sans les bérouettes
"JB"
Bonjour,

Pour 10.000 éléments 2,3s au lieu de 17,5 s

Sub ComparaisonChamp()
t = Timer()
Application.ScreenUpdating = False
Set MonDico1 = CreateObject("Scripting.Dictionary")
Set MonDico2 = CreateObject("Scripting.Dictionary")
Workbooks("classeur1.xls").Activate
For Each c In
Sheets(1).Range("A1:B5000").SpecialCells(xlCellTypeConstants, 23)
If Not MonDico1.Exists(c.Value) Then MonDico1.Add c.Value,
c.Address
Next
Workbooks("classeur2.xls").Activate
For Each c In Sheets(1).Range("A1:B5000")
If Not MonDico2.Exists(c) Then MonDico2.Add c.Value, c.Address
Next
Workbooks("classeur1.xls").Activate
For Each e In MonDico1
Range(MonDico1.Item(e)).Font.Color = IIf(MonDico2.Exists(e),
vblack, vbRed)
Next
MsgBox Timer() - t
End Sub

JB

On 31 mar, 00:11, "Fredo P."
Sub BpplusRap()
Dim c As Object, t
Dim plg1 As Range, Plg2 As Range
Application.ScreenUpdating = False
t = Timer()
'Workbooks("classeur1.xls").Activate
Set plg1 = Workbooks("Classeur1.xls").Sheets("Feuil1").Range("A1:A100")
'Workbooks("classeur2.xls").Activate
Set Plg2 = Workbooks("Classeur2.xls").Sheets("Feuil1").Range("A1:A100")
For Each c In plg1
If Plg2.Find(c) Is Nothing Then
c.Font.Bold = True
Else
c.Font.Bold = False
End If
Next
MsgBox Timer() - t
Application.ScreenUpdating = True
End Sub
--

Sans les bérouettes
"VASNIER"



Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé les
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où est
le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

--
Pascale- Masquer le texte des messages précédents -


- Afficher le texte des messages précédents -



Fredo P.
Le #5427871
Sur XL2007 ComparaisonChamp est dans tous les cas + rapide--



Sans les bérouettes
"JB"
Bonjour,

Pour 10.000 éléments 2,3s au lieu de 17,5 s

Sub ComparaisonChamp()
t = Timer()
Application.ScreenUpdating = False
Set MonDico1 = CreateObject("Scripting.Dictionary")
Set MonDico2 = CreateObject("Scripting.Dictionary")
Workbooks("classeur1.xls").Activate
For Each c In
Sheets(1).Range("A1:B5000").SpecialCells(xlCellTypeConstants, 23)
If Not MonDico1.Exists(c.Value) Then MonDico1.Add c.Value,
c.Address
Next
Workbooks("classeur2.xls").Activate
For Each c In Sheets(1).Range("A1:B5000")
If Not MonDico2.Exists(c) Then MonDico2.Add c.Value, c.Address
Next
Workbooks("classeur1.xls").Activate
For Each e In MonDico1
Range(MonDico1.Item(e)).Font.Color = IIf(MonDico2.Exists(e),
vblack, vbRed)
Next
MsgBox Timer() - t
End Sub

JB

On 31 mar, 00:11, "Fredo P."
Sub BpplusRap()
Dim c As Object, t
Dim plg1 As Range, Plg2 As Range
Application.ScreenUpdating = False
t = Timer()
'Workbooks("classeur1.xls").Activate
Set plg1 = Workbooks("Classeur1.xls").Sheets("Feuil1").Range("A1:A100")
'Workbooks("classeur2.xls").Activate
Set Plg2 = Workbooks("Classeur2.xls").Sheets("Feuil1").Range("A1:A100")
For Each c In plg1
If Plg2.Find(c) Is Nothing Then
c.Font.Bold = True
Else
c.Font.Bold = False
End If
Next
MsgBox Timer() - t
Application.ScreenUpdating = True
End Sub
--

Sans les bérouettes
"VASNIER"



Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé les
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où est
le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

--
Pascale- Masquer le texte des messages précédents -


- Afficher le texte des messages précédents -



VASNIER
Le #5426031
Bonjour à tous,

mille excuses de répondre si tardivement, j'ai été débordée ce début de
semaine. merci beaucoup pour toutes vos propositions j'ai trouvé mon bonheur
et résolu mon problème encore merci à tous
--
Pascale



Sur XL2007 ComparaisonChamp est dans tous les cas + rapide--



Sans les bérouettes
"JB"
Bonjour,

Pour 10.000 éléments 2,3s au lieu de 17,5 s

Sub ComparaisonChamp()
t = Timer()
Application.ScreenUpdating = False
Set MonDico1 = CreateObject("Scripting.Dictionary")
Set MonDico2 = CreateObject("Scripting.Dictionary")
Workbooks("classeur1.xls").Activate
For Each c In
Sheets(1).Range("A1:B5000").SpecialCells(xlCellTypeConstants, 23)
If Not MonDico1.Exists(c.Value) Then MonDico1.Add c.Value,
c.Address
Next
Workbooks("classeur2.xls").Activate
For Each c In Sheets(1).Range("A1:B5000")
If Not MonDico2.Exists(c) Then MonDico2.Add c.Value, c.Address
Next
Workbooks("classeur1.xls").Activate
For Each e In MonDico1
Range(MonDico1.Item(e)).Font.Color = IIf(MonDico2.Exists(e),
vblack, vbRed)
Next
MsgBox Timer() - t
End Sub

JB

On 31 mar, 00:11, "Fredo P."
Sub BpplusRap()
Dim c As Object, t
Dim plg1 As Range, Plg2 As Range
Application.ScreenUpdating = False
t = Timer()
'Workbooks("classeur1.xls").Activate
Set plg1 = Workbooks("Classeur1.xls").Sheets("Feuil1").Range("A1:A100")
'Workbooks("classeur2.xls").Activate
Set Plg2 = Workbooks("Classeur2.xls").Sheets("Feuil1").Range("A1:A100")
For Each c In plg1
If Plg2.Find(c) Is Nothing Then
c.Font.Bold = True
Else
c.Font.Bold = False
End If
Next
MsgBox Timer() - t
Application.ScreenUpdating = True
End Sub
--

Sans les bérouettes
"VASNIER"



Bonjour à toutes et à tous,

Je vais très souvent sur le fabuleux site d'Excelabo. J'ai trouvé les
macros ci-dessous et ai essayé de les utiliser pour mes deux fichiers à
comparer. Lorsque je les lance j'ai un sablier et le message suivant
Microsoft Excel (ne répond pas). voici les macros, je ne vois pas où est
le
problème. merci à vous

Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()

Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")

Collection1.Add Cellule1
Next Cellule1

Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")

collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()

Debug.Print "Test collection :" & Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub

--
Pascale- Masquer le texte des messages précédents -


- Afficher le texte des messages précédents -








Publicité
Poster une réponse
Anonyme