excel - Excel VBA: For loop with Match function, OnError works if no match is found, but inserts empty row

Question

I have a loop set up with a match function, so it checks if there is a match and then returns the result and repeats this for a defined number of times. I also have it set up so if there is an error, meaning if there is no match, it skips to the next loop. However, when no match is found, it leaves an empty row before inputting the next match below it. That's what I'm trying to avoid.

The way my code currently works is like this:

ws1 has multiple columns and rows of data. The first cell on every row in column A is the title. The titles are from a fixed selection (it's a drop down) which are determined by a list that is on ws2

ws2 has the list of titles, which is h3 until LastRow

ws3 Upon button click, it will match any results that correlate with variable_condition, and if it can't find a match it will go to the next loop, then print it on multiple rows from row 4 onwards

On ws3 it also inserts a shape which is assigned a macro (and thus becomes a button) on each row

What actually happens is, if it can't find a match, an empty row appears with this shape in column I.

I'm trying to make it so there isn't a blank row with a button and instead it just inserts the next looped result

My code below:

Sub CardsCollection()

Set ws1 = Sheets("Database")
Set ws2 = Sheets("Insert")
Set ws3 = Sheets("Sheet1")

Dim myCell As Range
Dim LastRow As Long

LastRow = ws2.Cells(ws2.Rows.Count, "H").End(xlUp).Row
Debug.Print LastRow

Dim test_string As String
test_string = "H" & LastRow
Dim test_range As Range
Set test_range = ws2.Range(test_string)

variable_condition = Range("E2")

NxtRw = 4

On Error Resume Next
For Each myCell In ws2.Range("H3" & ":" & test_string)
    row_num2 = Evaluate("MATCH(1,('" & ws1.Name & "'!A:A=""" & myCell & """)*('" & ws1.Name & "'!F:F=""" & variable_condition & """),0)")
    ws3.Range("A" & NxtRw).EntireRow.Value = ws1.Range("A" & row_num2).EntireRow.Value


Dim button_cell As String
    button_cell = "I" & NxtRw

    Dim bc_range As Range
    Set bc_range = Range(button_cell)

    Dim rect1 As Shape
    Dim rngToCheck As Range
    Dim clLeft As Double
    Dim clTop As Double
    Dim clWidth As Double
    Dim clHeight As Double

    Dim shpRec As Shape
    Set cl = Range(button_cell)

    With shpRec
        clLeft = cl.Left
        clTop = cl.Top
        clWidth = cl.Width - 5
        clHeight = cl.Height - 5
    End With


    Set shpRec = ActiveSheet.Shapes.AddShape(msoShapeRectangle, clLeft, clTop, clWidth, clHeight)


        With shpRec
        .Fill.ForeColor.RGB = RGB(242, 177, 135)
        .Line.Visible = False 'True
        .Line.ForeColor.RGB = RGB(255, 255, 255)
        .TextFrame.Characters.Text = "INSERT"
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextFrame.VerticalAlignment = xlVAlignCenter
        .TextFrame.Characters.Font.Size = 24
        .TextFrame.Characters.Font.Name = "SF Pro Display Black"
    End With

    NxtRw = NxtRw + 1
Next

End Sub

Any help would be appreciated! Thanks

EDIT: Updated code

Sub CardsCollection()

Call last_used_sort


Set ws1 = Sheets("Database")
Set ws2 = Sheets("Insert")
Set ws3 = Sheets("Sheet1")

Dim myCell As Range
Dim LastRow As Long

LastRow = ws2.Cells(ws2.Rows.Count, "H").End(xlUp).Row
Debug.Print LastRow

Dim test_string As String
test_string = "H" & LastRow
Dim test_range As Range
Set test_range = ws2.Range(test_string)

Dim row_num2 As Long

variable_condition = Range("E2")


NxtRw = 4


For Each myCell In ws2.Range("H3" & ":" & test_string)
    row_num2 = -1
    On Error Resume Next
    row_num2 = Evaluate("MATCH(1,('" & ws1.Name & "'!A:A=""" & myCell & """)*('" & ws1.Name & "'!F:F=""" & variable_condition & """),0)")
    On Error GoTo 0
    If row_num2 <> -1 Then
    ws3.Range("A" & NxtRw).EntireRow.Value = ws1.Range("A" & row_num2).EntireRow.Value

    Dim button_cell As String
    button_cell = "I" & NxtRw


    Dim bc_range As Range
    Set bc_range = Range(button_cell)


    Dim rect1 As Shape
    Dim rngToCheck As Range
    Dim clLeft As Double
    Dim clTop As Double
    Dim clWidth As Double
    Dim clHeight As Double

    Dim shpRec As Shape
    Set cl = Range(button_cell)

    Dim button_cell As String
    button_cell = "I" & NxtRw


    Dim bc_range As Range
    Set bc_range = Range(button_cell)


    Dim rect1 As Shape
    Dim rngToCheck As Range
    Dim clLeft As Double
    Dim clTop As Double
    Dim clWidth As Double
    Dim clHeight As Double

    Dim shpRec As Shape
    Set cl = Range(button_cell)

    Set shpRec = ActiveSheet.Shapes.AddShape(msoShapeRectangle, clLeft, clTop, clWidth, clHeight)


        With shpRec
        .Fill.ForeColor.RGB = RGB(242, 177, 135)
        .Line.Visible = False 'True
        .Line.ForeColor.RGB = RGB(255, 255, 255)
        .TextFrame.Characters.Text = "INSERT"
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextFrame.VerticalAlignment = xlVAlignCenter
        .TextFrame.Characters.Font.Size = 24
        .TextFrame.Characters.Font.Name = "SF Pro Display Black"
    End With


    NxtRw = NxtRw + 1

End If
Next

End Sub

标签： excelvba

Answer 1

正确的解决方案是隔离潜在错误的来源并进行处理。我在这里看到几个选项

使用您的Evaluate代码

For Each myCell In ws2.Range("H3" & ":" & test_string)
    row_num2 = -1
    On Error Resume Next
        row_num2 = Evaluate( ... )
    On Error GoTo 0
    If row_num2 <> -1 Then

        '...
        ' rest of your loop code

    End If
Next

使用更传统的WorksheetFunction方法，如果未找到匹配项，也会引发运行时错误

For Each myCell In ws2.Range("H3" & ":" & test_string)
    row_num2 = -1
    On Error Resume Next
        row_num2 = Application.WorksheetFunction.MATCH( ... )
    On Error GoTo 0
    If row_num2 <> -1 Then

        '...
        ' rest of your loop code

    End If
Next

使用Application.Matchwhich不会引发运行时错误，而是会返回错误值

Dim row_num2 As Variant
For Each myCell In ws2.Range("H3" & ":" & test_string)
    row_num2 = Application.MATCH( ... )

    If Not IsError(row_num2) Then

        '...
        ' rest of your loop code

    End If
Next

注意：我不完全理解你的 Match 公式，所以没有尝试翻译成 Match 函数版本。