Comparer 2 feuilles excel [VBA]
Résolu
binos359
Messages postés
2
Statut
Membre
-
binos359 Messages postés 2 Statut Membre -
binos359 Messages postés 2 Statut Membre -
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
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
-
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
