Comparer 2 feuilles excel et supprimé des données[VBA]

[binos359]

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
-(n'avoir que les nouveautés de la feuille 2 qui apparaisse dans une feuille 3)

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)
J'ai essayé pas mal de choses... qui ne mène à rien. J’espère que vous pourrez éclairer ma lanterne

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

 

[Staple1600]

Re : Comparer 2 feuilles excel et supprimé des données[VBA]

Bonsoir à tous

binos359 [highlight] [Bienvenue sur le forum][/code]
Ma façon de faire ce qu'indique le nom de la macro ci-dessous
(Test OK sur mon classeur de test, je te laisse tester et adapter en conséquence
sur ton fichier joint que je viens juste de voir mais pas encore ouvert )

Les nouvelles valeurs apparaissent sur la feuille Nouveau
Les doublons sont supprimés en feuille 2.

Sub CopierNouvellesValeursEtSupprimerDoublons()
Dim dl&, ld&
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Nouveau").Delete
On Error GoTo 0
Application.DisplayAlerts = True
dl = Sheets("Feuil2").Cells(Rows.Count, 1).End(xlUp).Row
ld = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Feuil2").Range("B1:B" & dl) = "=MATCH(RC[-1],Feuil1!R1C1:R" & ld & "C1,0)"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Nouveau"
On Error Resume Next
With Sheets("Feuil2").Columns("B:B")
    .SpecialCells(xlCellTypeFormulas, 16).Offset(, -1).Copy Sheets("Nouveau").Range("A1")
    .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
    .Delete
End With
On Error GoTo 0
End Sub

 

[binos359]

Re : Comparer 2 feuilles excel et supprimé des données[VBA]

Bonjour et merci pour votre aide.

Effectivement cela marche très bien j'ai juste dû modifier les colonnes

Encore merci