0
votes

Supprimer des lignes en fonction de valeurs introuvables dans une autre feuille

J'essaye de faire ce qui suit:

Comparez la valeur (une chaîne de caractères) qui est stockée dans la colonne B de la feuille de calcul "State = Closed", à toutes les valeurs de la colonne A d'une autre feuille de calcul appelée "Match List".
Supprimez toute ligne dans "State = Closed" qui ne correspond pas à la valeur "Match List" correspondante.
Le code doit fonctionner avec n'importe quelle longueur (car le nombre de lignes changera) dans la liste "Match List", ainsi qu'avec n'importe quelle longueur de feuille de calcul "State = Closed".

Sub ListRemove()
    Application.ScreenUpdating = False
    Dim i As Integer
    Dim b As Integer
    Dim Lastrow As Long
    Dim Lastrowb As Long
    Dim Del As Variant
    Worksheets("Match List").Activate
    Set Del = Range("A1:A67") '<--- This needs to be modified to work with any length Match List
    Lastrowb = Worksheets("State = Closed").Cells(Rows.Count, "A").End(xlUp).Row
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

    For i = 1 To Lastrow
        For b = 1 To Lastrowb
            If Worksheets("State = Closed").Cells(i, 2).Value <> Del(b) Then
                Worksheets("State = Closed").Rows(i).EntireRow.Delete
            End If
        Next
    Next

    Application.ScreenUpdating = True
    Worksheets("State = Closed").Activate
End Sub

Ceci supprime toutes les lignes de la feuille de calcul "State = Closed" au lieu des seules lignes qui ne contiennent pas de valeur correspondante dans la feuille de calcul de la liste de correspondance.

excel vba

1 commentaires

Au lieu de deux boucles, utilisez une boucle ( For i = 1 to LastRow ), puis utilisez WorksheetFunction.CountIf ou Application.Match pour essayer pour faire correspondre la chaîne de caractères à l'autre feuille ... si aucune correspondance, utilisez Union pour créer une plage de lignes à supprimer et supprimer à la fin (voir cette question pour l'approche).

3 Réponses :

0
votes

Ce code est testé. Notez l'utilisation du travail direct avec des objets.

Option Explicit

Sub ListRemove()

    Application.ScreenUpdating = False

    Dim matchList As Worksheet
    Set matchList = Worksheets("Match List")

    Dim matchRange As Range
    Set matchRange = matchList.Range("A1:A" & matchList.Cells(matchList.Rows.Count, 1).End(xlUp).Row)

    Dim closedList As Worksheet
    Set closedList = Worksheets("State = Closed")

    Dim searchRows As Long
    searchRows = closedList.Cells(closedList.Rows.Count, 1).End(xlUp).Row

    Dim i As Long
    For i = searchRows To 1 Step -1
        If IsError(Application.Match(closedList.Cells(i, 1).Value, matchRange, 0)) Then
            closedList.Cells(i, 1).EntireRow.Delete
        End If
    Next

End Sub

0 commentaires

1
votes

Trouvez mon code ci-dessous. Deux boucles for pour vérifier chaque valeur s'il existe une entrée identique dans une cellule de la deuxième feuille.

Sub List_Remove()
Dim i As Integer
Dim j As Integer
Dim k As Boolean
Dim shA As Worksheet
Dim shB As Worksheet

Set shA = Sheets("Sheet1") 'Worksheet that you want to compare with
Set shB = Sheets("Sheet2") 'Worksheet you want to delete rows from

For i = shB.UsedRange.Rows.Count To 1 Step -1
    k = False
    For j = 1 To shA.UsedRange.Rows.Count
        If shB.Cells(i, 1).Value = shA.Cells(j, 1).Value Then
           k = True
        End If
    Next
    If k = False Then
        shB.Rows(i).Delete
    End If
Next
EndSub

0 commentaires

0
votes

Supprimer les lignes (Union)

Le code

Option Explicit

Sub ListRemove()

    Application.ScreenUpdating = False

    ' Constants
    Const mlName As String = "Match List"
    Const mlFR As Long = 1
    Const mlCol As Variant = "A" ' e.g. 1 or "A"
    Const scName As String = "State = Closed"
    Const scFR As Long = 1
    Const scCol As Variant = "B" ' e.g. 1 or "A"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook

    ' Match List
    Dim ml As Worksheet: Set ml = wb.Worksheets(mlName)
    Dim mlLR As Long: mlLR = ml.Cells(ml.Rows.Count, mlCol).End(xlUp).Row
    Dim Del As Variant
    Del = ml.Range(ml.Cells(mlFR, mlCol), ml.Cells(mlLR, mlCol)).Value

    ' State = Closed
    Dim sc As Worksheet: Set sc = wb.Worksheets(scName)
    Dim scLR As Long: scLR = sc.Cells(sc.Rows.Count, scCol).End(xlUp).Row
    Dim rng As Range
    Set rng = sc.Range(sc.Cells(scFR, scCol), sc.Cells(scLR, scCol))

    ' Collecting Cells
    Dim cel As Range, URng As Range
    For Each cel In rng.Cells
        If IsError(Application.Match(cel.Value, Del, 0)) Then
            GoSub collectCells
        End If
    Next

    ' Deleting Rows
    'If Not URng Is Nothing Then URng.EntireRow.Delete
    ' First test with Hiding Rows.
    If Not URng Is Nothing Then URng.EntireRow.Hidden = True

    Application.ScreenUpdating = True

    sc.Activate

Exit Sub

collectCells:
    If Not URng Is Nothing Then
        Set URng = Union(URng, cel)
    Else
        Set URng = cel
    End If
    Return

End Sub

0 commentaires