building a loop based on if statement of two ranges in vba

Question

Thank you in advance for your help.

I am trying to build a macro (which in the end will be part of a bigger macro) that will compare two IDs and based on findings will perform another operation.

The code that I have at the moment only copies the values for each row without any consideration of ID in the first column. Here is the code:

Sub movingValues()

    'declaring/setting variables

    Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
    Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
    Dim SheetOneRng As Range, SheetTwoRng As Range
    Dim cell As Range, i As Integer

    Application.Calculation = xlCalculationManual

    Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
    Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
    SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
    SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
    Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
    Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)

    SheetOneWs.Range("B2:D13").Value = ""

    For i = 2 To SheetTwoLastRow
        'For Each cell In SheetTwoWs.Range(Cells(i, "B"), Cells(i, "M"))
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "No" Then
                SheetOneWs.Cells(cell.Row, "B").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "B").Value = "No data"
        Next cell
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "Maybe" Then
                SheetOneWs.Cells(cell.Row, "C").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "C").Value = "No data"
        Next cell
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "Yes" Then
                SheetOneWs.Cells(cell.Row, "D").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "D").Value = "No data"
        Next cell

    Next i


    Application.Calculation = xlCalculationManual
End Sub

My understanding is that I need to place that inside of another loop to match the IDs, so far I've tried:

For i = 2 To SheetOneLastRow


    For a = 2 To SheetTwoLastRow


    valTwo = Worksheets("SheetTwo").Range("A" & a).Value

    If Cells(i, 1) = valTwo Then

     'CODE FROM ABOVE'

    End if
  Next a
Next i

doesn't seem to work the way I intend it too, all your help will be greatly appreciated. The code initially was taken from the answer in here: Issue with copying values based on condition from one sheet to another VBA

Thank you once again for all your answers.

Best Regards, Sergej

One thing I noticed, in the first code you use i for For i = 2 To SheetTwoLastRow, and in the second block you use a for the same For a = 2 To SheetTwoLastRow. and i for For i = 2 To SheetOneLastRow If you nest the two inside of each other you might get unexpected results. — Plutian
– Plutian, Commented Dec 11, 2019 at 12:24
Use MATCH or FIND to find the correct row and then reference that. — SJR
– SJR, Commented Dec 11, 2019 at 14:06

SJR · Accepted Answer · 2019-12-11 15:19:05Z

1

As far as I can tell, this does what you want.

Sub x()

Dim rID As Range, rMonth As Range, rData As Range, rCell As Range, v As Variant

With Worksheets("SheetTwo")
    Set rID = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    Set rMonth = .Range("B1:M1")
    Set rData = .Range("B2").Resize(rID.Rows.Count, rMonth.Columns.Count)
End With

With Worksheets("SheetOne")
    For Each rCell In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
        v = Application.Match(rCell.Value, rID, 0)
        If IsNumeric(v) Then
            rCell.Offset(, 1).Value = rMonth.Cells(Application.Match("No", rData.Rows(v), 0))
            rCell.Offset(, 2).Value = rMonth.Cells(Application.Match("Maybe", rData.Rows(v), 0))
            rCell.Offset(, 3).Value = rMonth.Cells(Application.Match("Yes", rData.Rows(v), 0))
        End If
    Next rCell
End With

End Sub

answered Dec 11, 2019 at 15:19

SJR

23.1k6 gold badges21 silver badges26 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

Sergej Dikun Over a year ago

Thanks for that. However, if it doesn't find the value, macros throws an error. To replicate, remove one of three values and you will get an error. I like that it's much less code though!

Sergej Dikun Over a year ago

alright adding "On Error Resume Next" seemed to fixed the issue. It leaves out the empty space though, should I just add the line separetly that if value is " " then set value to "no data found" or there is another better way? :-)

SJR Over a year ago

Could easily build in similar error trapping as the If IsNumeric(v) Then line.

Plutian · Accepted Answer · 2019-12-11 15:11:32Z

1

Because I couldn't really bear looking at your horribly inefficient code, I've reworked it here based on the data provided in your previous question.

What this does is it loops over sheet 2 column A. Then for every cell it finds the corresponding ID and stores the row in "Hit".

It then finds three values in the row of the cell, and adds the month linked to every hit to the correct place in an array.

Then it pastes the array in one go to the correct range in sheet 1.

Sub movingValues()

    Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
    Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
    Dim cel As Range, hit As Range
    Dim Foundrow As Integer
    Dim arr() As Variant

    Application.Calculation = xlCalculationManual

    Set SheetOneWs = ThisWorkbook.Worksheets("Sheet1")
    Set SheetTwoWs = ThisWorkbook.Worksheets("Sheet2")
    SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
    SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row

    ReDim arr(1 To SheetOneLastRow - 1, 1 To 3)

    For Each cel In SheetTwoWs.Range("A2:A" & SheetTwoLastRow)
        Foundrow = SheetOneWs.Range("A1:A" & SheetOneLastRow).Find(cel.Value).Row - 1
            If Not Foundrow = 0 Then
                Set hit = SheetTwoWs.Rows(cel.Row).Find("No", SearchDirection:=xlNext)
                If Not hit Is Nothing Then
                    arr(Foundrow, 1) = SheetTwoWs.Cells(1, hit.Column).Value
                        Else
                        arr(Foundrow, 1) = "No Data"
                End If
                Set hit = SheetTwoWs.Rows(cel.Row).Find("Maybe", SearchDirection:=xlNext)
                If Not hit Is Nothing Then
                    arr(Foundrow, 2) = SheetTwoWs.Cells(1, hit.Column).Value
                        Else
                        arr(Foundrow, 2) = "No Data"
                End If
                Set hit = SheetTwoWs.Rows(cel.Row).Find("Yes", SearchDirection:=xlNext)
                If Not hit Is Nothing Then
                    arr(Foundrow, 3) = SheetTwoWs.Cells(1, hit.Column).Value
                        Else
                        arr(Foundrow, 3) = "No Data"
                End If
            End If
    Next cel

    SheetOneWs.Range("B2:D" & SheetOneLastRow) = arr

End Sub

As you can probably see when trying it, reading your values into an array first makes this pretty much instant, since it saves on "expensive" write actions. With the tests in place and this structure it should be much more straightforward and rigid than your previous code. Using Find means it only needs to loop over each row once, further increasing performance.

Please note, it's best to back up your data before trying in case of unexpected results and/or errors.

answered Dec 11, 2019 at 15:11

Plutian

2,3093 gold badges17 silver badges24 bronze badges

6 Comments

Sergej Dikun Over a year ago

Wow, thanks for that, man! Defo on the right track there. For some reason it missed out on two of the "ID" when I've tried it: imgur.com/42e7Y3g the image from sheet2 with those IDs there : imgur.com/MB3dSy9

Plutian Over a year ago

No idea why the row with "4" gets skipped, as this doesn't happen for me when I replicate your data. The bottom one gets skipped since "11" is on your first sheet twice, and the data will only be linked to the first one.

Sergej Dikun Over a year ago

Cool, I've rewritten the IDs and it seemed to work properly this time. Thank you very much for your response and the code. It's a long learning journey for me with those so it will be messy at the start :-)

Plutian Over a year ago

No problem, happy to help. We've all had to learn sometime, and it's not too long ago for me learning all this. Just happy I can pas it on.

Sergej Dikun Over a year ago

hmm... for whatever reason it started to give an error "Object variable or With block variable not set" at this line: ``` Foundrow = SheetOneWs.Range("A1:A" & SheetOneLastRow).Find(cel.Value).Row - 1 ````

|

Collectives™ on Stack Overflow

building a loop based on if statement of two ranges in vba

2 Answers 2

3 Comments

6 Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

3 Comments

6 Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related