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

这是我到目前为止的尝试，我感觉它很漂亮，但我希望逻辑至少是有道理的。我试图浏览更改工作表中的每一行，搜索LOBID的所有表格（A，B，C，... L），然后搜索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

VBA（Excel）：多个工作表中多个条件的循环复制

1 个答案: