清除数组中行的内容-具有3个条件

Question

Some time ago I wanted to create a code that will clear the content of the rows in specific ranges of my sheet but only under a condition if the ID in the first column of my ranges matches the defined name with the first characters. I have got an excellent support from QHarr who made the code work.

However, now, I wanted to extend the code for a few more conditions ie have 3 IDs (Defined names) to which the rows should be matched and then cleared. The current code works for 1 ID (Defined name) and after many trials I cannot make it work by extending the condition to 3 IDs (Defined names)

Here is how the case looks before running the code:

This is the desired outcome => the rows in the array where 3 IDs matches to defined name - clear in the range:

Below is the code that works great for 1 ID:

Option Explicit
Public Sub ClearCells()

    Const COLUMN_START1 As Long = 2
    Const COLUMN_END1 As Long = 5
    Const COLUMN_START2 As Long = 7
    Const COLUMN_END2 As Long = 10
    Const COLUMN_START3 As Long = 12
    Const COLUMN_END3 As Long = 15
    Const START_ROW As Long = 8
    Const L_MY_DEFINED_NAME As String = "ID"

    Dim loopRanges()

    loopRanges = Array(COLUMN_START1, COLUMN_END1, COLUMN_START2, COLUMN_END2, COLUMN_START3, COLUMN_END3)

    Dim targetSheet As Worksheet, index As Long, unionRng As Range
    Dim id As Long                               'Or , ID As String?

    Set targetSheet = ThisWorkbook.Sheets("Sheet1")
    id = ThisWorkbook.Names(L_MY_DEFINED_NAME).RefersToRange.Value

    Application.ScreenUpdating = False

    With targetSheet

        For index = LBound(loopRanges) To UBound(loopRanges) Step 2

            Dim lngLastRow As Long, ClearRange As Range, rng As Range

            lngLastRow = .Cells(.Rows.Count, loopRanges(index)).End(xlUp).Row '
            If lngLastRow < START_ROW Then lngLastRow = START_ROW

            Set ClearRange = .Range(.Cells(START_ROW, loopRanges(index)), .Cells(lngLastRow, loopRanges(index + 1)))

            For Each rng In ClearRange.Columns(1).Cells
                If Not IsEmpty(rng) Then
                    If Left$(rng.Value, Len(id)) = id Then '<== match found
                        If Not unionRng Is Nothing Then
                            Set unionRng = Union(unionRng, rng.Resize(1, ClearRange.Columns.Count)) '<== gather all matches into a union range

                        Else
                            Set unionRng = rng.Resize(1, ClearRange.Columns.Count)
                        End If
                    End If
                End If
            Next rng
        Next index
    End With

    If Not unionRng Is Nothing Then unionRng.ClearContents '<== or after Then: 'Debug.Print unionRng.Address' to check what is cleared
    Application.ScreenUpdating = True
MsgBox "Done", vbInformation
End Sub

I was trying to extend it to 3 ids (defined names) on multiple ways and none of them works eg In the statement 'If Left$(rng.Value, Len(id)) = id Then' , I was adding And, Or for id2 and id3 (after declaring them in the same way as ID) - however, the code does not read them. I had also tried to add the paragraphs of the condition for id below as for id2 and id3 - but in the outcome, the whole content of the sheet is cleared. Does someone know the trick to extend it?

Answer 1

The advantage of the solutions below is that you can continue using your approach of start and end columns to extend for more ranges.

If you know that they will match on length you can do:

Option Explicit
Public Sub ClearCells()

    Const COLUMN_START1 As Long = 2
    Const COLUMN_END1 As Long = 5
    Const COLUMN_START2 As Long = 7
    Const COLUMN_END2 As Long = 10
    Const COLUMN_START3 As Long = 12
    Const COLUMN_END3 As Long = 15
    Const START_ROW As Long = 8
    'Const L_MY_DEFINED_NAME As String = "ID"

    Dim loopRanges()

    loopRanges = Array(COLUMN_START1, COLUMN_END1, COLUMN_START2, COLUMN_END2, COLUMN_START3, COLUMN_END3)

    Dim targetSheet As Worksheet, index As Long, unionRng As Range
    Dim id As Long                               'Or , ID As String?

    Set targetSheet = ThisWorkbook.Sheets("Sheet1")
    'id = ThisWorkbook.Names(L_MY_DEFINED_NAME).RefersToRange.Value

    Application.ScreenUpdating = False

    With targetSheet

        For index = LBound(loopRanges) To UBound(loopRanges) Step 2

            Dim lngLastRow As Long, ClearRange As Range, rng As Range

            lngLastRow = .Cells(.Rows.Count, loopRanges(index)).End(xlUp).Row '
            If lngLastRow < START_ROW Then lngLastRow = START_ROW

            Set ClearRange = .Range(.Cells(START_ROW, loopRanges(index)), .Cells(lngLastRow, loopRanges(index + 1)))

            For Each rng In ClearRange.Columns(1).Cells
                If Not IsEmpty(rng) Then
                    If Not IsError(Application.Match(rng.Value, targetSheet.Range("B3:B5"), 0)) Then 'Left$(rng.Value, Len(id)) = id Then '<== match found
                        If Not unionRng Is Nothing Then
                            Set unionRng = Union(unionRng, rng.Resize(1, ClearRange.Columns.Count)) '<== gather all matches into a union range

                        Else
                            Set unionRng = rng.Resize(1, ClearRange.Columns.Count)
                        End If
                    End If
                End If
            Next rng
        Next index
    End With

    If Not unionRng Is Nothing Then unionRng.ClearContents '<== or after Then: 'Debug.Print unionRng.Address' to check what is cleared
    Application.ScreenUpdating = True
MsgBox "Done", vbInformation
End Sub

Or:

Option Explicit
Public Sub ClearCells()

    Const COLUMN_START1 As Long = 2
    Const COLUMN_END1 As Long = 5
    Const COLUMN_START2 As Long = 7
    Const COLUMN_END2 As Long = 10
    Const COLUMN_START3 As Long = 12
    Const COLUMN_END3 As Long = 15
    Const START_ROW As Long = 8
    'Const L_MY_DEFINED_NAME As String = "ID"

    Dim loopRanges()

    loopRanges = Array(COLUMN_START1, COLUMN_END1, COLUMN_START2, COLUMN_END2, COLUMN_START3, COLUMN_END3)

    Dim targetSheet As Worksheet, index As Long, unionRng As Range
    Dim id As Long                               'Or , ID As String?

    Set targetSheet = ThisWorkbook.Sheets("Sheet1")
    'id = ThisWorkbook.Names(L_MY_DEFINED_NAME).RefersToRange.Value

    Dim ids()
    ids = targetSheet.Range("B3:B5").Value

    Application.ScreenUpdating = False

    With targetSheet

        For index = LBound(loopRanges) To UBound(loopRanges) Step 2

            Dim lngLastRow As Long, ClearRange As Range, rng As Range

            lngLastRow = .Cells(.Rows.Count, loopRanges(index)).End(xlUp).Row '
            If lngLastRow < START_ROW Then lngLastRow = START_ROW

            Set ClearRange = .Range(.Cells(START_ROW, loopRanges(index)), .Cells(lngLastRow, loopRanges(index + 1)))

            For Each rng In ClearRange.Columns(1).Cells
                If Not IsEmpty(rng) Then
                    If Not IsError(Application.Match(rng.Value, Application.WorksheetFunction.index(ids, 0, 1), 0)) Then 'Left$(rng.Value, Len(id)) = id Then '<== match found
                        If Not unionRng Is Nothing Then
                            Set unionRng = Union(unionRng, rng.Resize(1, ClearRange.Columns.Count)) '<== gather all matches into a union range

                        Else
                            Set unionRng = rng.Resize(1, ClearRange.Columns.Count)
                        End If
                    End If
                End If
            Next rng
        Next index
    End With

    If Not unionRng Is Nothing Then unionRng.ClearContents '<== or after Then: 'Debug.Print unionRng.Address' to check what is cleared
    Application.ScreenUpdating = True
MsgBox "Done", vbInformation
End Sub

In the first answer you simply lookup the current cell value against the range holding the IDs with

If Not IsError(Application.Match(rng.Value, targetSheet.Range("B3:B5"), 0)) 

If there is a match then you add it to the items for later clearance.

In the second answer you put the IDs into an array and when looping check if the current cell value is in the array with:

If Not IsError(Application.Match(rng.Value, Application.WorksheetFunction.index(ids, 0, 1), 0)) 

Edit:

If you don't know that they will match on length you can extend your original code to loop all the IDs like this:

Option Explicit

Public Sub ClearCells()

    Const COLUMN_START1 As Long = 2
    Const COLUMN_END1 As Long = 5
    Const COLUMN_START2 As Long = 7
    Const COLUMN_END2 As Long = 10
    Const COLUMN_START3 As Long = 12
    Const COLUMN_END3 As Long = 15
    Const START_ROW As Long = 8
    'Const L_MY_DEFINED_NAME As String = "ID"

    Dim loopRanges()

    loopRanges = Array(COLUMN_START1, COLUMN_END1, COLUMN_START2, COLUMN_END2, COLUMN_START3, COLUMN_END3)

    Dim targetSheet As Worksheet, index As Long, unionRng As Range
    Dim id As Long                               'Or , ID As String?

    Set targetSheet = ThisWorkbook.Sheets("Sheet1")
    'id = ThisWorkbook.Names(L_MY_DEFINED_NAME).RefersToRange.Value

    Dim ids(), i As Long
    ids = targetSheet.Range("B3:B5").Value

    Application.ScreenUpdating = False

    With targetSheet

        For i = LBound(ids, 1) To UBound(ids, 1)

        For index = LBound(loopRanges) To UBound(loopRanges) Step 2

            Dim lngLastRow As Long, ClearRange As Range, rng As Range

            lngLastRow = .Cells(.Rows.Count, loopRanges(index)).End(xlUp).Row '
            If lngLastRow < START_ROW Then lngLastRow = START_ROW

            Set ClearRange = .Range(.Cells(START_ROW, loopRanges(index)), .Cells(lngLastRow, loopRanges(index + 1)))

            For Each rng In ClearRange.Columns(1).Cells
                If Not IsEmpty(rng) Then
                    If Left$(rng.Value, Len(ids(i, 1))) = ids(i, 1) Then '<== match found
                        If Not unionRng Is Nothing Then
                            Set unionRng = Union(unionRng, rng.Resize(1, ClearRange.Columns.Count)) '<== gather all matches into a union range

                        Else
                            Set unionRng = rng.Resize(1, ClearRange.Columns.Count)
                        End If
                    End If
                End If
            Next rng
        Next index

        Next i

    End With

    If Not unionRng Is Nothing Then unionRng.ClearContents '<== or after Then: 'Debug.Print unionRng.Address' to check what is cleared
    Application.ScreenUpdating = True
MsgBox "Done", vbInformation
End Sub

Answer 2

a "quick & dirty" code:

Sub main()
    Dim iCol As Long
    Dim filters As Variant, filter As Variant
    Dim cell As Range

    filters = Array("1234", "432", "5544") '<- list your named ranges values

    With ThisWorkbook.Sheets("Sheet1")
        For iCol = 2 To 12 Step 5
            For Each cell In .Range(.Cells(8, iCol), .Cells(.Rows.count, iCol).End(xlUp))
                For Each filter In filters
                    If InStr(cell.Text, filter) > 0 Then
                        cell.Resize(, 4).ClearContents
                        Exit For
                    End If
                Next
            Next
        Next
    End With
End Sub

---

a less dirty code, limiting the iteration to the actual number of matches:

Sub main2()
    Dim iCol As Long
    Dim filters As Variant, filter As Variant
    Dim f As Range

    filters = Array("1234", "432", "5544")

    With ThisWorkbook.Sheets("Sheet001")
        For iCol = 2 To 12 Step 5
            With .Range(.Cells(8, iCol), .Cells(.Rows.count, iCol).End(xlUp))
                For Each filter In filters
                    Set f = .Find(what:=filter, LookIn:=xlValues, lookat:=xlPart)
                    If Not f Is Nothing Then
                        Do
                            f.Resize(, 4).ClearContents
                            Set f = .FindNext(f)
                        Loop While Not f Is Nothing
                    End If
                Next
            End With
        Next
    End With
End Sub