Search with multiple criteria shows Runtime error 91

user_18341940 0
Viewed 39

I have worksheet, with two filled columns, a & b, respect to criteria at range("E1") and ("E2")

I need to use VBA to search till the end of rows.

If criteria is meet, the cell with entire row will be selected. However, I'm not able to make a msgbox to alert user there is no data meet the criteria.

The code is as below I appreciate any advise is given.

Sub Testing()
    Dim c As Range
    Dim rngG As Range

    For Each c In Intersect(ActiveSheet.UsedRange, Columns("a"))
        If c = Sheet1.Range("E1") Then
            If rngG Is Nothing Then Set rngG = c.EntireRow
            Set rngG = Union(rngG, c.EntireRow)
        End If
    Next c

    rngG.Select

    Dim d As Range
    Dim rnG As Range

    For Each d In Intersect(ActiveSheet.UsedRange, Columns("b"))
        If d = Sheet1.Range("E2") Then
            If rnG Is Nothing Then Set rnG = d.EntireRow
            Set rnG = Union(rnG, d.EntireRow)
        End If
    Next d

    Intersect(rngG, rnG).Select  
End Sub
vba excel
1 Answers

Select Criteria Rows By Using a Loop

Option Explicit

Sub Testing()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    
    ' Not using the worksheet name here, makes only sense if you mean
    ' to do this operation on several worksheets.
    Dim dws As Worksheet: Set dws = ActiveSheet
    If dws.Name = sws.Name Then Exit Sub ' doesn't work on the same worksheet
    Dim drg As Range: Set drg = dws.UsedRange
    
    Dim durg As Range
    Dim dCell As Range
    Dim sValue As Variant

    sValue = sws.Range("E1").Value
    For Each dCell In Intersect(drg, dws.Columns("A")).Cells
        If dCell.Value = sValue Then
            If durg Is Nothing Then Set durg = dCell.EntireRow _
                Else Set durg = Union(durg, dCell.EntireRow)
        End If
    Next dCell

    sValue = sws.Range("E2").Value
    For Each dCell In Intersect(drg, dws.Columns("B")).Cells
        If dCell.Value = sValue Then
            If durg Is Nothing Then Set durg = dCell.EntireRow _
                Else Set durg = Union(durg, dCell.EntireRow)
        End If
    Next dCell

    If durg Is Nothing Then
        MsgBox "No match found.", vbExclamation
        Exit Sub
    End If
    
    ' The following line is only necessary if you change your mind
    ' related to the 'ActiveSheet' at the beginning of the code.
    'dws.Select ' prevent 'Run-time error '91'' when another worksheet is active
    durg.Select

End Sub
user_98140690
Related