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

Question

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

cs_Le Pivert · Answer

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

binos359 · Answer

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 :)

Comparer 2 feuilles excel [VBA]

2 réponses

Discussions similaires