Supprimer plusieurs lignes

[eillon]

Bonjour,

Je cherche à supprimer plusieurs lignes en feuilles en les entrant dans la feuilles 2
visiblement, il me supprime les données communes en feuil2 colonne A, mais pas en colonne B

Sub supprimer_Marques_Références()
 
If MsgBox("ATTENTION, vous aller supprimer les lignes du F U", vbExclamation + vbOKCancel + vbApplicationModal + 0, "Lionel") = vbOK Then
Dim i As Integer, j As Integer, DLV1 As Integer, DLV2 As Integer
 
        DLV2 = Sheets(2).Columns(1).Find("", [A65536], , , xlByRows, xlPrevious).Row - 1
        DLV1 = Sheets(1).Columns(2).Find("", [B65536], , , xlByRows, xlPrevious).Row - 1
 
For i = DLV1 To 1 Step -1
    For j = 1 To DLV2
        If Sheets(1).Range("B" & i).Value = Sheets(2).Range("A" & j).Value Then _
        Sheets(1).Rows(i).Delete
          Next j
    Next i
        DLV2 = Sheets(2).Columns(1).Find("", [A65536], , , xlByRows, xlPrevious).Row - 1
        DLV1 = Sheets(1).Columns(1).Find("", [A65536], , , xlByRows, xlPrevious).Row - 1
 
For i = DLV1 To 1 Step -1
    For j = 1 To DLV2
        If Sheets(1).Range("A" & i).Value = Sheets(2).Range("A" & j).Value Then _
        Sheets(1).Rows(i).Delete
          Next j
    Next i
End If
        derniereLigne = ActiveSheet.UsedRange.Rows.Count
        Application.ScreenUpdating = False
        For r = derniereLigne To 1 Step -1
        If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
    Next r
End Sub

 

[skoobi]

Re : Supprimer plusieurs lignes

Bonsoir,
Tout d'abord, avec DLV1 et DLV2 et récupères chaque fois la dernière ligne vide.
Il y a beaucoup plud simple comme instruction:

DLV1 = Sheets(1).Cells(65536,2).end(xlup).row

Ensuite pour le code, on pourra mieux t'aider si tu nous envoie un bout de fichier zippé < 48.8 ko car c'est pas toujours facile de s'imaginer ce qui se passe lors de l'execution d'une macro.

Bonne soirée.

 

[eillon]

Re : Supprimer plusieurs lignes

je joint mon fichier.

Les valeurs en Feuil1 servent à supprimer les lignes qui les contiennent sur la feuille "PAOSLDG".

J'ai mis en "A" Feuil1 si elles apparissent en "A" dans PAOSLDG.
Pareil pour le B.

Si ce n'est pas assez clair n'hésite pas.

 

[eillon]

Re : Supprimer plusieurs lignes

J'ai modifier avec ça, ça marche bien à première vu mais c'est super loooong.
J'ai plus 12000 lignes 😕

Sub supprimer_Marques_Références()

If MsgBox("ATTENTION, vous aller supprimer les marques et references", vbExclamation + vbOKCancel + vbApplicationModal + 0, "Lionel") = vbOK Then

Dim i As Integer, J As Integer, DLV1 As Integer, DLV2 As Integer, DLV3 As Integer, DLV4 As Integer


        
        DLV2 = Sheets(2).Cells(65536, 1).End(xlUp).Row
        DLV1 = Sheets(1).Cells(65536, 1).End(xlUp).Row
        
For i = DLV1 To 1 Step -1

    For J = 1 To DLV2
    
    If Sheets(1).Range("A" & i).Value = Sheets(2).Range("A" & J).Value Then _
        Sheets(1).Rows(i).Delete
        Next J
    Next i
               
        DLV4 = Sheets(2).Cells(65536, 2).End(xlUp).Row
        DLV3 = Sheets(1).Cells(65536, 2).End(xlUp).Row
    
For i = DLV3 To 1 Step -1

    For J = 1 To DLV4
    
        If Sheets(1).Range("B" & i).Value = Sheets(2).Range("B" & J).Value Then _
        Sheets(1).Rows(i).Delete
        
        
         Next J
    Next i
    
    End If
    
        derniereLigne = ActiveSheet.UsedRange.Rows.Count
        Application.ScreenUpdating = False
        For r = derniereLigne To 1 Step -1
        If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
    Next r
End Sub

 

[eillon]

Re : Supprimer plusieurs lignes

En fait quelqu'un m'avait fait cette macro qui est instantanée sur 15000 lignes, j'aurais aimé l'adapter pour avoir le même résultat de vitesse.

Sub NonDoublons2()
 Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In Range([B1], [B65000].End(xlUp))
    If Not MonDico1.Exists(c.Value) Then MonDico1.Add c.Value, c.Value
  Next c
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For Each c In Range([A1], [A65000].End(xlUp))
    If Not MonDico1.Exists(c.Value) Then
       If Not mondico2.Exists(c.Value) Then mondico2.Add c.Value, c.Value
    End If
  Next c
  Range("C1:C" & mondico2.Count) = Application.Transpose(mondico2.items)
End Sub

 

[skoobi]

Re : Supprimer plusieurs lignes

Re,

regarde si ce code est plus rapide:

Sub test()
Dim i As Integer, J As Integer, DLV1 As Integer, DLV2 As Integer, DLV3 As Integer, DLV4 As Integer
Dim liste2a As New Collection, liste2b As New Collection
If MsgBox("ATTENTION, vous aller supprimer les marques et references", vbExclamation + vbOKCancel + vbApplicationModal + 0, "Lionel") = vbOK Then
    DLV2 = Sheets(2).Cells(65536, 1).End(xlUp).Row
    DLV1 = Sheets(1).Cells(65536, 1).End(xlUp).Row
    For J = 1 To DLV2
        liste2a.Add Sheets(2).Cells(J, 1).Value
    Next J
    For i = DLV1 To 1 Step -1
        For J = 1 To liste2a.Count
            If Sheets(1).Range("A" & i).Value = liste2a(J) Then
                Sheets(1).Rows(i).Delete
            End If
        Next J
    Next i
    
    DLV4 = Sheets(2).Cells(65536, 1).End(xlUp).Row
    DLV3 = Sheets(1).Cells(65536, 1).End(xlUp).Row
    For J = 1 To DLV4
        liste2b.Add Sheets(2).Cells(J, 1).Value
    Next J
    For i = DLV3 To 1 Step -1
        For J = 1 To liste2b.Count
            If Sheets(1).Range("A" & i).Value = liste2b(J) Then
                Sheets(1).Rows(i).Delete
            End If
        Next J
    Next i
End If
derniereLigne = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = derniereLigne To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r

End Sub

Attention: il ne faut pas qu'il y ai de doublons dans la "Feuil1" ou Sheets(2).
Le fichier que tu as envoyé est apparement déjà "nettoyé" donc pas pu voir si ça marche bien.