Excel VBA：带有匹配函数的循环，如果找不到匹配项，OnError 有效，但插入空行

Question

我设置了一个带有 match 函数的循环，因此它会检查是否存在匹配，然后返回结果并重复此操作定义的次数。我也设置了它，所以如果有错误，这意味着如果没有匹配，它会跳到下一个循环。但是，当没有找到匹配项时，它会在输入下一个匹配项之前留下一个空行。这就是我要避免的。

我的代码目前的工作方式是这样的：

ws1 具有多列和多行数据。 A 列中每一行的第一个单元格是标题。标题来自固定选择（它是一个下拉菜单），由 ws2 上的列表确定

ws2 有标题列表，在 LastRow 之前是 h3

ws3 点击按钮后，它会匹配任何与 variable_condition 相关的结果，如果找不到匹配则进入下一个循环，然后从第 4 行开始在多行上打印它

在 ws3 上，它还在每一行插入一个形状，该形状被分配了一个宏（因此成为一个按钮）

实际发生的情况是，如果找不到匹配项，则会在 I 列中出现具有此形状的空行。

我正在尝试使它没有一个带有按钮的空白行，而是插入下一个循环结果

我的代码如下：

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

任何帮助将不胜感激！谢谢

编辑：更新代码

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

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.Match 不会抛出运行时错误，而是返回错误值

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 函数版本。

Answer 2

首先，使用On Error Resume Next 是用VBA 编写的最糟糕的代码行之一，因为它只会隐藏错误。它不会向您显示您的代码有什么问题，或者您在代码中的假设可能是错误的。所以你真的应该完全避免使用它。如果您的代码依赖于这样的行来运行，那么它确实应该得到改进。

现在，为了快速修复您的代码，您希望如果没有找到匹配项，则求助于下一次迭代。由于没有示例数据，您的比较语句很难阅读，我将在下面为您提供快速修复：

所以在代码中更改您的On Error Resume Next 部分，如下所示：

NxtRw = 4

On Error GoTo NextLoop
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

并指出代码应该在哪里继续这样：

    NxtRw = NxtRw + 1
NextLoop: 'this indicates where to continue
Next

End Sub

最好用If 语句检查是否可能匹配，这样您就可以简单地依靠该逻辑跳到循环的末尾。