Comparer 2 feuilles excel [VBA]
Résolu
binos359
Messages postés
2
Date d'inscription
Statut
Membre
Dernière intervention
-
binos359 Messages postés 2 Date d'inscription Statut Membre Dernière intervention -
binos359 Messages postés 2 Date d'inscription Statut Membre Dernière intervention -
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
A voir également:
- Comparer deux feuilles excel et afficher différence vba
- Word et excel gratuit - Guide
- Liste déroulante excel - Guide
- Nombre de jours entre deux dates excel - Guide
- Différence entre tcp et udp - Guide
- Si et excel - Guide
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:
Tu peux adapter des inputBox avec les codes qui sont dans les boutons en en faisant des macros
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