VBA (Excel): Copied copy by multiple criteria across multiple sheets
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.
- Each observation has a common identifier in column A (
- Also has a specific identifier in column E (
Each pair is unique, as each
can exist in multiple sheets under several
, but will only connect
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