Excel VBA宏：迭代一个页面上的值以检查另一页面上的匹配并分配值

Question

我想要做的：遍历一个页面上的值以检查另一个页面上的匹配，如果找到匹配项，则从第二页的同一行但不同的列中获取一个值。

我已经尝试了很长时间了。我是 VBA 脚本/Excel 的新手，可能会错误地解决问题，因此我在这里问！

到目前为止我的代码：

Sub InsertData()
ScreenUpdating = False


Dim wks As Worksheet

Dim subSheet As Worksheet
Set subSheet = Sheets("Sheet4")
Dim rowRangeSub As Range
Dim LastRowSub As Long
LastRowSub = subSheet.Cells(subSheet.Rows.Count, "C").End(xlUp).Row
Set rowRangeSub = subSheet.Range("C2:C" & LastRowSub)
Dim subGroupList As ListObject


Dim rowRange As Range
Dim colRange As Range

Dim LastCol As Long
Dim LastRow As Long

Dim Found As Range
'START OF SHEET1'
Set wks = Sheets("SHEET1")
LastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row

Set rowRange = wks.Range("B2:B" & LastRow)
'Loop through each row in B column (Names)'
For Each rrow In rowRange
    If Not IsEmpty(rrow) Then
        With Sheets("Sheet4").Range("C2:C" & LastRowSub)

            Set Found = .Find(What:=rrow, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)

            If Not Found Is Nothing Then
                'Debug.Print "Found"'
                wks.Cells(rrow.Row, "K").Value = "Found"
            Else
                wks.Cells(rrow.Row, "K").Value = "Not Found"

                'Debug.Print "Not Found"'
            End If
        End With
    End If
Next rrow

'END OF SHEET1'
'START OF SHEET2'
Set wks = Sheets("SHEET2")
LastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row
Set rowRange = wks.Range("B2:B" & LastRow)

'END OF SHEET2'
'START OF SHEET3'
Set wks = Sheets("SHEET3")
LastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row
Set rowRange = wks.Range("B2:B" & LastRow)

'END OF SHEET3'


ScreenUpdating = True
End Sub

Excel文件中的设置如下： 这三个工作表Sheet1、Sheet2、Sheet3 在其前10 列(A-J) 中包含大量数据，第11 列(K) 是找到数据时要插入的位置。相关数据名称位于 B 列中，其中 B:1 只是“名称”作为标题。列中还有一些空单元格需要考虑。

第 4 张工作表 Sheet4 在其前 5 列中包含一些数据。要匹配的名称可以在 C 列中找到，如果找到匹配项，则应该从 Cells(Found.Row, "E") 中收集数据，其中 "E" 是 E 列。

这个问题一直困扰着我，因为 .Find() 函数似乎无法按我的预期工作，因为它有时会发现相反的情况。

我的主要问题是：如何为行分配正确的值？

wks.Cells(rrow.Row, "K").Value = rowRangeSub.Cells(Found.Row, "E").Value

我觉得我已经测试了至少 10 种不同的分配方式，但我不断地出错。大多数情况下是不匹配错误。

感谢任何帮助！

从阅读 cmets 开始编辑： 好的，就这样： 所有列都格式化为文本。 A 栏：个人号码：不相关 B 列：姓名：表格为：姓氏，名字。这将在搜索匹配项时使用。 C 到 J 列与一个人的各种信息不相关。 K 列：此列单元格开始为空。这是由宏来填充的。

我在 Excel 文件中有三本不同的书，它们的数据看起来像我解释的那样，只是每本书中的数据不同。

第四本书是这样的： A 列和 B 列与根本不需要的信息无关。

C 列：是姓氏、名字形式的名称。这应该是与其他书中 B 列的单元格进行比较的列单元格。

D 列：不相关

E 列：这是 Sheet4 的重要部分。对于每个人，每行都有一个“组号”，可以在此列中找到。

我想要做的是比较 Sheet1-3 中 B 列中的每个单元格，以便在 Sheet4 中 C 列中匹配。如果找到匹配项（并非所有人都分配了一个组，因此可能找不到匹配项）然后从 Sheet4 中找到匹配项的行和列“E”中获取单元格信息，将此信息放在 Sheet1-3 中的行中和“K”列。

示例数据（有没有办法提交表格？）： 表 1：

B 栏

桌森，笔

纸、墨

橡皮擦、屏幕

COLUMN K此时为空

Sheet4：

C 列

纸、墨

橡皮擦，屏幕

E 栏

55

77

运行宏，Sheet1 在宏之后：

B 栏

桌森，笔

纸、墨

橡皮擦，屏幕

K 栏

[第一个条目为空，因为没有找到匹配项]

55

77

希望这是可以理解的！

Answer 1

我使用脚本字典简化了这个过程。

Sub InsertData()
    Dim lastRow As Long, x As Long
    Dim dicNames, k As String, v As Variant

    Set dicNames = CreateObject("scripting.dictionary")
    'Create list of Names to compare against and values to update
    With Worksheets("Sheet4")
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        For x = 2 To lastRow
        
            k = .Cells(x, 3).Value  'Name from Column C
            v = .Cells(x, 5).Value  'Value From Column E

            'Add Key Value pairs to Dictionary
            If Not dicNames.Exists(k) Then dicNames.Add k, v
        Next
    End With

    ProcessWorksheet Worksheets("Sheet1"), dicNames
    ProcessWorksheet Worksheets("Sheet2"), dicNames
    ProcessWorksheet Worksheets("Sheet3"), dicNames

End Sub

Sub ProcessWorksheet(ws As Worksheet, ByRef dicNames)
    Dim k As String, v As Range
    Dim lastRow As Long, x As Long
    With ws
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        For x = 2 To lastRow
            k = .Cells(x, 2)    'If Name from Column B
            If dicNames.Exists(k) Then
                .Cells(x, 11) = dicNames(k) 'Then Column K = Value from Sheet4
            End If
        Next
    End With
End Sub

Answer 2

Sub InsertData()
    Dim lastRow As Long, x As Long
    Dim dicNames, k As String, v As Variant

    Set dicNames = CreateObject("scripting.dictionary")
    'Create list of Names to compare against and values to update
    With Worksheets("Sheet4")
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        For x = 2 To lastRow
        
            k = .Cells(x, 3).Value  'Name from Column C
            v = .Cells(x, 5).Value  'Value From Column E

            'Add Key Value pairs to Dictionary
            If Not dicNames.Exists(k) Then dicNames.Add k, v
        Next
    End With

    ProcessWorksheet Worksheets("Sheet1"), dicNames
    ProcessWorksheet Worksheets("Sheet2"), dicNames
    ProcessWorksheet Worksheets("Sheet3"), dicNames

End Sub

Sub ProcessWorksheet(ws As Worksheet, ByRef dicNames)
    Dim k As String, v As Range
    Dim lastRow As Long, x As Long
    With ws
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        For x = 2 To lastRow
            k = .Cells(x, 2)    'If Name from Column B
            If dicNames.Exists(k) Then
                .Cells(x, 11) = dicNames(k) 'Then Column K = Value from Sheet4
            End If
        Next
    End With
End Sub

基本使用 Thomas Inzina 提供的代码，稍作改动：

    If dicNames.Exists(k) Then
        newV = IIf(dicNames(k) = v, v, dicNames(k) & "," & v)
        dicNames.Remove (k)
        dicNames.Add k, newV
    Else
        dicNames.Add k, v
    End If

这会考虑重复。

我也使用了this cleaning function，因为我在 VBA 中找不到内置的。像这样使用它们：

k = CleanTrim(.Cells(X, 3).Value)  'Name from Column C
k = CleanTrim(.Cells(X, 2).Value)  'If Name from Column B