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

Question

背景
我有一个包含许多数据表的主文件，并且有一个不断更新的请求更改列表。我需要编写一个宏，以便它将沿着“更改”表中的每一行运行，并在实际数据表中找到其对应项。我需要将相关单元格从更改表复制到其特定表中存在的相应行。

信息

• 每个观测值在 A 列中都有一个通用标识符 (LOBID)
• E 列中还有一个特定标识符 (CourseCode)

• 每对都是唯一的，因为每个 CourseCode 可以存在于多个 LOBID 下的多个工作表中，但只能与 LOBID 配对> 一次。

  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
  

这是我到目前为止的尝试，我感觉它很不错，但我希望逻辑至少有意义。我试图遍历“更改”表中的每一行，在所有表(A、B、C、...L)中搜索 LOBID，然后搜索 CourseCode。当找到匹配对时，我希望将值从 ChangeWS 复制到数据表中的匹配单元格(有许多值需要复制，但为了代码简洁起见，我将它们省略了)。它不会抛出任何错误，但似乎根本没有做任何事情。如果有人至少可以将我推向正确的方向，我将不胜感激。

Answer 1

已编译但未测试:

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