CODEWITHSUNDEEP
excelvba
Sam
Sam

Reputation: 109

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

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

Upvotes: 0

Views: 2751

Answers (2)

chris neilsen
chris neilsen

Reputation: 53126

The correct solution is to isolate the source of potential error and handle it. I see several options here

Using your Evaluate code

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

Using a more conventional WorksheetFunction approach, which will also throw a runtime error if a match is not found

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

Using Application.Match which will not throw a runtime error, but retrn a error value instead

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

Note: I don't fully understand your Match formula, so haven't tried to translate to the Match function version.

Upvotes: 3

Luuklag
Luuklag

Reputation: 3914

First off, using On Error Resume Next is one of the worst lines of code one could write in VBA, since it only hides errors. It doesn't show you what is wrong with your code, or perhaps your assumption in your code are wrong. So you really should avoid using this at all. If your code relies on a line like this to function it should really be improved.

Now for a quick fix on your code, you want it to be the case that if no match is found, you resort to the next iteration. As your comparison statement is rather hard to read without sample data I'll do you the quick fix below:

So change your On Error Resume Next part in the code like this:

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

And indicate where the code should continue like this:

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

End Sub

It would be better to check if a match could be possible with an If statement, so you could simply rely on that logic to skip to the end of the loop.

Upvotes: 1

Related Questions