VBA (Excel): Copied copy by multiple criteria across multiple sheets
Background
I have a main file that contains many data sheets and I have a list of requested changes that are constantly updated. I need to write a macro such that it will skip every row in the Changes sheet and find a copy of it in the actual data sheets. I need to copy the corresponding cells from the change sheet to the corresponding row where it exists on its specific sheet.
Information
- Each observation has a common identifier in column A (
LOBID
) - Also has a specific identifier in column E (
CourseCode
) -
Each pair is unique, as each
CourseCode
can exist in multiple sheets under severalLOBID
, but will only connectLOBID
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 is my attempt so far, I have a feeling that I can't, but I hope the logic at least makes sense. I am trying to run each row in the Changes sheet, search all sheets (A, B, C, ... L) for LOBID and then CourseCode. When a matching pair is found, I hope to copy the value from changeWS to the corresponding cell in the data table (there are many values to copy, but I left them for brevity of code). This doesn't throw any errors, but doesn't seem to do anything. If someone could even nudge me in the right direction, I'd appreciate it.
source to share
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
source to share