Comparer 2 feuilles excel [VBA] [Résolu/Fermé]

Signaler
Messages postés
2
Date d'inscription
samedi 7 février 2015
Statut
Membre
Dernière intervention
8 février 2015
-
Messages postés
2
Date d'inscription
samedi 7 février 2015
Statut
Membre
Dernière intervention
8 février 2015
-
Bonjour,

Je me permets de solliciter votre aide car je bloque sur la programmation VBA pour un projet.
Ce que j'ai:

2 feuilles excel avec des listes, le numéro d'identification est unique.

Ce que je voudrai:
-comparer la feuille 2 avec la feuille 1
-si il y a correspondance on supprime la ligne
-Si l'objet feuille2 ne se retrouve pas dans feuille1 on copie la ligne dans une autre page
-si quelque chose de la feuille 1 n'est pas sur la feuille 2 on supprime la ligne aussi

Comment modifier ce code pour y parvenir?
(pour l'instant celui ci supprime uniquement les doublons présents dans une même page et par conséquent garde les infos de la feuille 1 qui ne sont pas présentes dans la feuille 2)

Merci beaucoup :)





Sub doublons ()


choix = InputBox("Choisissez l'action qui vous intéresse :" & Chr(10) & Chr(10) & "1. Colorer les doublons (colorer la cellule)" & Chr(10) & "2. Colorer les doublons (colorer la ligne entière)" & Chr(10) & "3. Effacer les doublons (en laissant la ligne vide)" & Chr(10) & "4. Supprimer les doublons (ligne entière)" & Chr(10) & "5. Supprimer les lignes vides" & Chr(10) & Chr(10) & "Entrez le n° de l'action et cliquez sur OK :")
If choix = "" Then Exit Sub

choix2 = ""
If choix = 1 Or choix = 2 Or choix = 3 Or choix = 4 Then choix2 = InputBox("Entrez la lettre de la colonne où les doublons doivent être recherchés : »)
If choix = 5 Then choix2 = InputBox("Entrez la lettre de la colonne à prendre en compte (si la cellule de cette colonne est vide, la ligne sera supprimée) :")
If choix2 = "" Then Exit Sub

Application.ScreenUpdating = False
test = Timer

der_ligne = Range(choix2 & "65000").End(xlUp).Row

Dim tab_cells()
ReDim tab_cells(der_ligne - 1)

For ligne = 1 To der_ligne
tab_cells(ligne - 1) = Range(choix2 & ligne)
Next

nb = 0
If choix = 4 Or choix = 5 Then compteur = 0

For ligne = 1 To der_ligne
contenu = tab_cells(ligne - 1)

If (choix = 1 Or choix = 2) And contenu <> "" Then 'Colorer doublons
For i = 1 To der_ligne
If contenu = tab_cells(i - 1) And ligne <> i Then 'Si doublon
nb = nb + 1
If choix = 1 Then
Range(choix2 & ligne).Interior.ColorIndex = 3
Else
Range(ligne & ":" & ligne).Interior.ColorIndex = 3
End If
Exit For
End If
Next
End If

If (choix = 3 Or choix = 4) And ligne > 1 And contenu <> "" Then 'Effacer/supprimer doublons
For i = 1 To ligne - 1
If contenu = tab_cells(i - 1) Then 'Si doublon
nb = nb + 1
If choix = 3 Then
Range(ligne & ":" & ligne).ClearContents
Else
Range(ligne + compteur & ":" & ligne + compteur).Delete
compteur = compteur - 1
End If
Exit For
End If
Next
End If

If choix = 5 And contenu = "" Then 'Lignes vides
Range(ligne + compteur & ":" & ligne + compteur).Delete
compteur = compteur - 1
nb = nb + 1
End If
Next

res_test = Format(Timer - test, "0" & Application.DecimalSeparator & "000")
Application.ScreenUpdating = True

If nb = 0 And choix = 5 Then
dd = MsgBox("Aucune ligne vide trouvée ...", 64, "Résultat")
ElseIf nb = 0 Then
dd = MsgBox("Aucun doublon trouvé dans la colonnne " & UCase(choix2) & " ...", 64, "Résultat")
ElseIf choix = 5 Then
dd = MsgBox(nb & " lignes supprimées (en " & res_test & " secondes)", 64, "Résultat")
ElseIf choix = 4 Then
dd = MsgBox(nb & " doublons supprimés (en " & res_test & " secondes)", 64, "Résultat")
ElseIf choix = 3 Then
dd = MsgBox(nb & " doublons effacés (en " & res_test & " secondes)", 64, "Résultat")
Else
dd = MsgBox(nb & " doublons passés en rouge (en " & res_test & " secondes)", 64, "Résultat")
End If

End Sub

2 réponses

Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
Bonjour,

Le code que tu as trouvé sur le net compare 2 colonnes situées sur la même feuille

Voici un exemple avec 2 colonnes situées dans 2 feuilles à adapter:

Mettre dans une UserForm 5 boutons avec ce code:

Option Explicit
Dim der_ligne, cel1, cel2, li
'colorie doublons
Private Sub CommandButton1_Click()
der_ligne = Range("A" & "65000").End(xlUp).Row
For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne)
    For Each cel2 In Sheets("Feuil2").Range("A1:A" & der_ligne)
      If cel1 = cel2 Then
        li = li + 1
        cel1.Interior.ColorIndex = 3
        cel2.Interior.ColorIndex = 3
      End If
    Next
  Next
End Sub
'rétablie couleur initiale
Private Sub CommandButton2_Click()
der_ligne = Range("A" & "65000").End(xlUp).Row
Sheets("Feuil1").Range("A1:A" & der_ligne).Interior.ColorIndex = xlNone
Sheets("Feuil2").Range("A1:A" & der_ligne).Interior.ColorIndex = xlNone
End Sub
'effacer contenu la ligne doublon feuil2
Private Sub CommandButton3_Click()
der_ligne = Range("A" & "65000").End(xlUp).Row
For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne)
    For Each cel2 In Sheets("Feuil2").Range("A1:A" & der_ligne)
      If cel1 = cel2 Then
        li = li + 1
     cel2.ClearContents
      End If
    Next
  Next
End Sub
'copier ligne sans doublons dans feuil3
Private Sub CommandButton4_Click()
der_ligne = Range("A" & "65000").End(xlUp).Row
For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne)
    For Each cel2 In Sheets("Feuil2").Range("A1:A" & der_ligne)
      If cel1 = cel2 Then
        li = li + 1
        cel1.Interior.ColorIndex = 3
       End If
        Next
  Next
   li = 0
  For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne)
 If cel1.Interior.ColorIndex = xlNone Then
    li = li + 1
    Sheets("Feuil3").Select
    Range("A" & li).Value = cel1
    End If
        Next
Sheets("Feuil1").Range("A1:A" & der_ligne).Interior.ColorIndex = xlNone
 End Sub
'supprimer la ligne doublon feuil2
Private Sub CommandButton5_Click()
der_ligne = Range("A" & "65000").End(xlUp).Row
For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne)
    For Each cel2 In Sheets("Feuil2").Range("A1:A" & der_ligne)
      If cel1 = cel2 Then
        li = li + 1
     cel2.Delete
      End If
    Next
  Next
End Sub
Private Sub UserForm_Initialize()
CommandButton1.Caption = "Colorier doublons"
CommandButton2.Caption = "Rétablir couleurs"
CommandButton3.Caption = "Effacer lignes"
CommandButton4.Caption = "Copier lignes"
CommandButton5.Caption = "Supprimer lignes"
End Sub


Tu peux adapter des inputBox avec les codes qui sont dans les boutons en en faisant des macros
Messages postés
2
Date d'inscription
samedi 7 février 2015
Statut
Membre
Dernière intervention
8 février 2015

Bonjour,
Merci pour votre réponse.

J'ai cependant trouvé une manière plus simple de faire ce que je voulais.
Je vais quand même essayer de faire marcher votre code.

Encore merci :)