Excel VBA 按国家匹配两个工作表数据并写入第三工作表问题求解

需求说明 #

现有3个Excel工作表：

• Accounts表：存储账户数据，共约2万行，字段包含Account（账户号）、Country（所属国家）
• Users表：存储用户数据，共约50行，字段包含Email（用户邮箱）、Country（所属国家）
• AccountTeams表：目标输出表，需逐行存储匹配结果，每行格式为【用户邮箱、对应匹配的账户号】
  匹配规则：对Accounts表的每个账户，匹配Users表中Country字段相同的用户，生成对应关联行写入AccountTeams表。
  参考示例匹配结果：US用户john.doe@company.com匹配到账户1234567，GB用户jane.doe@company.com匹配到账户2345678、9876543，FR无对应用户则不生成记录。

原有代码问题 #

原有代码仅遍历了Users表的行，未遍历所有Accounts表的行，同时硬编码仅匹配AU国家、行号复用逻辑错误，导致只能拿到第一条匹配记录。

修复后实现代码 #

Sub MatchAccountToUser()
    Dim accounts As Worksheet
    Dim accountteams As Worksheet
    Dim usr As Worksheet
    Dim accLastRow As Long, userLastRow As Long, targetRow As Long
    Dim i As Long, j As Long, currentCountry As String
    
    ' 工作表绑定
    Set accounts = Worksheets("Accounts")
    Set accountteams = Worksheets("AccountTeams")
    Set usr = Worksheets("Users")
    
    ' 获取两个源表的最大行号
    accLastRow = accounts.Cells(accounts.Rows.Count, "A").End(xlUp).Row ' 假设Account在Accounts表A列
    userLastRow = usr.Cells(usr.Rows.Count, "A").End(xlUp).Row ' 假设Email在Users表A列
    
    ' 初始化目标表：先写表头，目标数据从第2行开始写
    accountteams.Cells.Clear
    accountteams.Cells(1, 1) = "用户邮箱"
    accountteams.Cells(1, 2) = "关联账户号"
    targetRow = 2
    
    ' 关闭屏幕更新提升2万行数据处理速度
    Application.ScreenUpdating = False
    
    ' 外层遍历所有账户
    For i = 2 To accLastRow
        currentCountry = accounts.Cells(i, "B").Value ' 假设Country在Accounts表B列
        ' 内层匹配同国家的用户
        For j = 2 To userLastRow
            If usr.Cells(j, "B").Value = currentCountry Then ' 假设Country在Users表B列
                ' 写入匹配结果
                accountteams.Cells(targetRow, 1) = usr.Cells(j, "A").Value
                accountteams.Cells(targetRow, 2) = accounts.Cells(i, "A").Value
                targetRow = targetRow + 1
            End If
        Next j
    Next i
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

列索引调整说明 #

如果你的表字段所在列和代码假设不一致，对应修改以下参数即可：

• accounts.Cells(i, "B")：修改为Accounts表Country字段对应的列号/列名
• usr.Cells(j, "B")：修改为Users表Country字段对应的列号/列名
• accounts.Cells(i, "A")：修改为Accounts表Account字段对应的列号/列名
• usr.Cells(j, "A")：修改为Users表Email字段对应的列号/列名

内容的提问来源于stack exchange，提问作者ddukes