comparer 2 colonnes sur feuil 1 et feuil 3 Résolu/Fermé

Question

Bonjour,   

Sous EXCEL 97 (oui je sais, ce n'est pas de toute première jeunesse)  
J'ai ce premier code qui fonctionne à merveille pour comparer colonne A feuille 1 et colonne A feuille 2 et supprimer les doublons sur feuille 2.  


Sub compare()  
Dim LastLig1 As Long, LastLig2 As Long, i As Long  
Dim c As Range  
   
Application.ScreenUpdating = False  
LastLig1 = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row  
With Sheets("Feuil2")  
    LastLig2 = .Cells(Rows.Count, 1).End(xlUp).Row  
    For i = LastLig2 To 1 Step -1  
        Set c = Sheets("Feuil1").Range("A1:A" & LastLig1).Find(.Range("A" & i).Value, lookat:=xlWhole)  
        If Not c Is Nothing Then  
            .Rows(i).Delete  
            LastLig2 = LastLig2 - 1  
            Set c = Nothing  
        End If  
    Next i  
    If LastLig2 > 0 Then .Range("A1:L" & LastLig2).Copy Sheets("Feuil1").Range("A" & LastLig1 + 1)  
End With  
End Sub  






par contre, je voudrais effectuer la même chose entre feuille 1 et feuille 3 et le code suivant ne fonctionne pas. Quelqu'un saurait-il me dire pourquoi SVP ?  




Sub compare2()  
Dim LastLig1 As Long, LastLig3 As Long, i As Long  
Dim c As Range  
   
Application.ScreenUpdating = False  
LastLig1 = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row  
With Sheets("Feuil3")  
    LastLig3 = .Cells(Rows.Count, 1).End(xlUp).Row  
    For i = LastLig3 To 1 Step -1  
        Set c = Sheets("Feuil1").Range("A1:A" & LastLig1).Find(.Range("A" & i).Value, lookat:=xlWhole)  
        If Not c Is Nothing Then  
            .Rows(i).Delete  
            LastLig3 = LastLig3 - 1  
            Set c = Nothing  
        End If  
    Next i  
    If LastLig3 > 0 Then .Range("A1:L" & LastLig3).Copy Sheets("Feuil1").Range("A" & LastLig1 + 1)  
End With  
End Sub  

Merci pour votre aide.  




Configuration: Windows XP / Firefox 9.0.1

Lentzouille2 · Answer

Bonjour,

Est-ce que ta feuille 3 se nomme bien Feuil3 ?

nicodrum · Answer

c'est juste feuil2 qu'il faut changer en feuil3 pas tous les 2 en 3.

pijaku · Answer

Bonjour,
Combien de lignes doit traiter cette macro?

michel_m · Answer

Bonjour 

Il faut donc comparer 1 à 2, 1 à 3, 1 à 4, et virer les lignes de données identiques dans a 1 dans 2 3 4 ? 

as tu des doublons internes dans dans  1 2 3 4 ? 

as tu des données dans les autres colonnes ?

 Michel

pijaku · Answer

Bonjour, 
Récapitulons pour être tout à fait exact. 
Tu as 4 feuilles de 45 000 lignes. 
Tu as des éléments en Feuil1 que l'on retrouve en feuil2, 3 et 4. 
Par contre, pas d'éléments communs entre les Feuilles 2, 3 et 4. 
Tu veux par conséquent supprimer les doublons. 
Donc questions :
Tu veux les supprimer en Feuil1 ou en Feuil2, 3 et 4? 
Peux t'il y avoir des doublons au sein même de chaque feuille?
Si oui : suppression?

Cordialement, 
Franck P

michel_m · Answer

Bonjour  

testé sur 10000 lignes suppression en 1,3 seconde  

Dim Dico2 As Object, Dico3 As Object, Dico4 As Object  
Sub comparer_1234()  
Dim derlig1 As Long, cle  
Dim T_in  
Dim start As Single  

start = Timer  
'---initialisations  
With Sheets(1)  
     Application.ScreenUpdating = False  
     derlig1 = .Columns("A").Find("*", , , , , xlPrevious).Row  
     T_in = Application.Transpose(.Range("A1:A" & derlig1).Value)  
' création des dictionnaires feuilles 2,3,4  
     creer_dicos 2, Dico2  
     creer_dicos 3, Dico3  
     creer_dicos 4, Dico4  

'----détection et suppression des doublons intercolonnes  
     For cptr = 1 To UBound(T_in)  
          cle = .Cells(cptr, 1)  
          If Dico2.exists(cle) Then Dico2.Remove (cle)  
          If Dico2.exists(cle) Then Dico3.Remove (cle)  
          If Dico2.exists(cle) Then Dico4.Remove (cle)  
     Next  
 End With  
'----restitutions des feuilles épurées  
     '---RESTITUTIONS PROVISOIRE COLONNE B POUR ESSAIS  
   Sheets(2).Range("B1").Resize(Dico2.Count, 1) = Application.Transpose(Dico2.keys)   
   Sheets(3).Range("B1").Resize(Dico3.Count, 1) = Application.Transpose(Dico3.keys) 
   Sheets(4).Range("B1").Resize(Dico4.Count, 1) = Application.Transpose(Dico4.keys)  
     
   '--- LIGNES A ACTIVER APRES ESSAIS  
   'With Sheets(2)  
     '.Columns("A").ClearContents  
    ' .Range("A1").Resize(Dico2.Count, 1) = Application.Transpose(dico2.keys)  
   'End With  
   'With Sheets(3)  
     '.Columns("A").ClearContents  
    ' .Range("A1").Resize(Dico3.Count, 1) = Application.Transpose(dico3.keys)  
   'End With  
   'With Sheets(4)  
     '.Columns("A").ClearContents  
    ' .Range("A1").Resize(Dico4.Count, 1) = Application.Transpose(dico4.keys)  
   'End With  
       
MsgBox " suppression des occurences communes terminée en " & Timer - start & " .sec"  
End Sub  

Sub creer_dicos(Num, Dico)  
Dim derlig As Long  
Set Dico = CreateObject("scripting.dictionary")  
With Sheets(Num)  
     derlig = .Columns("A").Find("*", , , , , xlPrevious).Row  
     For cptr = 1 To derlig  
          Dico.Add .Cells(cptr, 1).Value, 1  
     Next  
End With  
End Sub  


le classeur de test  
https://www.cjoint.com/?3AmiEUzQ47D  


suis absent jusqu'à 18-19h  

 Michel

pijaku · Answer

Re-  
En attendant le retour de sambrero, voici ma proposition (2,214844 secondes pour 45 000 lignes par feuille) :  
!!!! ATTENTION : Lorsque l'on copie un code sur Internet, toujours travailler sur une copie de son document original. Surtout si on trouve un Delete dans ce code!!!!  

Sub SupprimeDoublonsColonneA()  
'Sources d'inspiration:  
'boisgontierjacques : 
    'http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm#SupDoubBD  
'Michel_m :
    'http://www.commentcamarche.net/forum/affich-24145736-comparer-2-colonnes-sur-feuil-1-et-feuil-3#11  
Dim Dico, CleDico  
Dim TablFeuil1, TablAutresFeuilles  
Dim DrLig As Long, i As Long  
Dim Wsh As Worksheet  
Dim t  

t = Timer  
Application.ScreenUpdating = False  
Set Dico = CreateObject("Scripting.Dictionary")  
With Sheets("Feuil1")  
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row  
    TablFeuil1 = Application.Transpose(.Range("A1:A" & DrLig).Value)  
    For i = 1 To UBound(TablFeuil1)  
        Dico(TablFeuil1(i)) = ""  
    Next i  
End With  
For Each Wsh In ThisWorkbook.Worksheets(Array("Feuil2", "Feuil3", "Feuil4"))  
    With Sheets(Wsh.Name)  
        DrLig = .Range("A" & Rows.Count).End(xlUp).Row  
        TablAutresFeuilles = Application.Transpose(.Range("A1:A" & DrLig).Value)  
        For i = UBound(TablAutresFeuilles) To 1 Step -1  
            CleDico = TablAutresFeuilles(i)  
            If Dico.Exists(CleDico) Then  
                .Rows(i).Delete  
            End If  
        Next i  
    End With  
Next Wsh  
MsgBox "Suppression terminée en : " & Timer - t & " secondes"  
Set Dico = Nothing  
End Sub  

Cordialement,  
Franck P

pijaku · Answer

Bonjour,
@Michel_m : ballade magnifique Scrogneugneu... Là je t'envie vraiment !!

@Sambrero : n'hésite pas à donner de tes nouvelles régulièrement, j'ai aussi craint de n'avoir bossé pour rien. Ici une fois n'est pas coutume et c'est vraiment rageant... D'autant plus qu'une procédure comme celle demandée ne se fait pas en 10 minutes...

Bon L'incompatibilité de type erreur d'exécution 13 ne le fait pas avec TES données sur MA version d'excel (2003). Je suppute donc grandement ta version (97) de nous jouer des tours...
N'achèterais tu point une version plus récente? (je plaisante).

Je regarde ça dans la journée...

pijaku · Answer

Re- 
Alors après recherche, en ce qui concerne les variables tableaux sous Excel 97, j'ai trouvé ce tuto extrait de la FAQ XLD. Le 2- Les Tableaux Multidimensionnels aborde le cas d'Excel 97 et comment déclarer une variable tableau : 
ATTENTION: : Sous Excel 97 et MAC, quand on affecte une plage de cellules à un tableau, il ne faut pas déclarer de variable Tableau mais tout simplement en Variant=> .Dim TabContributeurs et non Dim TabContributeurs() 
Enfin, même si on affecte qu'une colonne=>TabContributeurs=Range("A1:A20"),on aura un tableau bidimensionnel de 20 lignes sur une colonne.(Ubound(TabContributeurs,1)=20 et Ubound(TabContributeurs,1)=1  

De plus, je suppose, mais là dessus je n'ai rien trouvé, que "Application.transpose" pose problème sous 97. En effet, dans mon code précédent, les variables tableaux étaient belles et bien déclarées en Variant, donc à part ça, je ne vois pas ce qui gène l'exécution sous 97... 

Le nouveau code tient donc compte de ceci, vous pourrez le constater dans les lignes en gras ci dessous. 

Option Explicit 

Sub SupprimeDoublonsColonne1Version2() 

'Sources d'inspiration: 
'boisgontierjacques : 
    'http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm#SupDoubBD 
'Michel_m : 
    'http://www.commentcamarche.net/forum/affich-24145736-comparer-2-colonnes-sur-feuil-1-et-feuil-3#11 
'FAQ XLD : 
    'http://www.excel-downloads.com/forum/93353-vba-les-tableaux-le-ki-ki-de-zon.html 

Dim Dico, CleDico 
Dim TablFeuil1, TablAutresFeuilles 
Dim DrLig As Long, i As Long 
Dim Wsh As Worksheet 
Dim t 

t = Timer 
Application.ScreenUpdating = False 
Set Dico = CreateObject("Scripting.Dictionary") 
With Sheets("Feuil1") 
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row 
    TablFeuil1 = .Range("A1:A" & DrLig) 
    For i = 1 To UBound(TablFeuil1, 1) 
        Dico(TablFeuil1(i, 1)) = "" 
    Next i 
End With 
For Each Wsh In ThisWorkbook.Worksheets(Array("Feuil2", "Feuil3", "Feuil4")) 
    With Sheets(Wsh.Name) 
        DrLig = .Range("A" & Rows.Count).End(xlUp).Row 
        TablAutresFeuilles = .Range("A1:A" & DrLig) 
        For i = UBound(TablAutresFeuilles, 1) To 1 Step -1 
            CleDico = TablAutresFeuilles(i, 1)
            If Dico.Exists(CleDico) Then 
                .Rows(i).Delete 
            End If 
        Next i 
    End With 
Next Wsh 
MsgBox "Suppression terminée en : " & Timer - t & " secondes" 
Set Dico = Nothing 
End Sub-- 
Cordialement, 
Franck P

Comparer 2 colonnes sur feuil 1 et feuil 3

9 réponses

Discussions similaires