VBA (Excel): Looped copy on multiple criteria in multiple worksheets - vba

Question

Background
I have a master file which holds many sheets of data, and I have a list of requested changes which is constantly being updated. I need to write a macro such that it will run down each row in the Changes sheet and find its counterpart within the actual data sheets. I need to copy the relevant cells from the change sheet to the respective row where it exists in its particular sheet.
Information
Each observation has a general identifier in Column A (LOBID)
Also has a specific identifier in Column E (CourseCode)
Each pair is unique, as each CourseCode can exist within multiple sheets under multiple LOBIDs but will only pair with an LOBID once.
Sub InputChanges()
Dim changeWS As Worksheet: Dim destWS As Worksheet
Dim rngFound As Range: Dim strFirst As String
Dim LOBID As String: Dim CourseCode As String
Dim i As Integer: Dim LastRow As Integer
Const SHEET_NAMES As String = "Sheet A, Sheet B, Sheet C, etc."
Set changeWS = Sheets("Changes")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each destWS In ActiveWorkbook.Worksheets
If InStr(1, SHEET_NAMES, destWS.Name, vbBinaryCompare) > 0 Then
For i = 4 To changeWS.Range("A" & Rows.Count).End(xlUp).Row
LOBID = changeWS.Cells(i, 2)
CourseCode = changeWS.Cells(i, 5)
Set rngFound = Columns("A").Find(LOBID, Cells(Rows.Count, "A"), xlValues, xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If Cells(rngFound.Row, "E").Value = CourseCode Then
Cells(rngFound.Row, "AP").Value = changeWS.Cells(i, 24).Value
End If
Set rngFound = Columns("A").Find(LOBID, rngFound, xlValues, xlWhole)
Loop While rngFound.Address <> strFirst
End If
Next i
End If
Next
Set rngFound = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Here's my attempt so far, I have a feeling it's pretty off but I hope the logic at least makes sense. I am attempting to run through each row in the Changes sheet, search through all the Sheets (A, B, C, ... L) for LOBID, then for CourseCode. When a matching pair is found, I'm hoping to copy the value from the changeWS to the matched cell in the datasheet (there are many values to copy but I've left them out for code brevity). It doesn't throw any errors but it doesn't seem to do anything at all. If someone could at least nudge me in the right direction, I'd appreciate it.

Answer 1

Compiled but not tested:
Sub InputChanges()
Dim changeWS As Worksheet, rw As Range
Dim i As Integer
Set changeWS = ActiveWorkbook.Sheets("Changes")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = 4 To changeWS.Range("A" & Rows.Count).End(xlUp).Row
Set rw = GetRowMatch(CStr(changeWS.Cells(i, 2)), CStr(changeWS.Cells(i, 5)))
If Not rw Is Nothing Then
rw.Cells(1, "AP").Value = changeWS.Cells(i, 24).Value
changeWS.Cells(i, 2).Interior.Color = vbGreen
Else
changeWS.Cells(i, 2).Interior.Color = vbRed
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function GetRowMatch(LOBID As String, CourseCode As String) As Range
Dim arrSheets, s, sht As Worksheet, rv As Range, f As Range
Dim addr1 As String
arrSheets = Array("Sheet A", "Sheet B", "Sheet C") ', etc.")
For Each s In arrSheets
Set s = ActiveWorkbook.Sheets(s)
Set f = s.Columns(1).Find(LOBID, Cells(Rows.Count, "A"), xlValues, xlWhole)
If Not f Is Nothing Then
addr1 = f.Address()
Do
If f.EntireRow.Cells(5) = CourseCode Then
Set GetRowMatch = f.EntireRow 'return the entire row
Exit Function
End If
Set f = s.Columns(1).Find(LOBID, f, xlValues, xlWhole)
Loop While f.Address() <> addr1
End If
Next s
'got here with no match - return nothing
Set GetRowMatch = Nothing
End Function