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

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

Answer 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

Answer 2

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.