多工作簿VLOOKUP精确匹配异常的VBA代码排查求助

本人是VBA新手，编写了一段实现数据分组、计数、排序及跨3个工作簿执行VLOOKUP的代码。目前分组、计数、排序功能正常，但VLOOKUP无法实现精确匹配，恳请帮忙排查问题。

原代码如下：

Sub GroupMentionsSortedAndVLookupThreeWorkbooks()
    Dim wsSource As Worksheet
    Dim wsOutput As Worksheet
    Dim mentionsRange As Range
    Dim mentionDict As Object
    Dim mention As Variant
    Dim lastRow As Long
    Dim i As Long
    Dim outputRow As Long
    Dim sortedMentions As Variant
    Dim currentLetter As String
    Dim firstLetter As String
    
    Dim wb2 As Workbook
    Dim ws2 As Worksheet
    Dim lookupRange2 As Range
    Dim lookupValue As String
    Dim lookupResult2 As Variant
    
    Dim wb3 As Workbook
    Dim ws3 As Worksheet
    Dim lookupRange3 As Range
    Dim lookupResult3 As Variant
    
    Dim wb4 As Workbook
    Dim ws4 As Worksheet
    Dim lookupRange4 As Range
    Dim lookupResult4 As Variant
    
    Dim combinedResult As String
    Dim finalResult As String
    
    ' Set source and output worksheets in Workbook 1
    Set wsSource = ThisWorkbook.Sheets("Sheet1") ' Source of the mentions
    Set wsOutput = ThisWorkbook.Sheets("Sheet2") ' Output sheet for grouped mentions
    
    ' Clear the output sheet
    wsOutput.Cells.Clear
    
    ' Find the last row with data in Sheet1 (Column A)
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' Set the range for the mentions
    Set mentionsRange = wsSource.Range("A1:A" & lastRow)
    
    ' Create a dictionary object to store mention counts
    Set mentionDict = CreateObject("Scripting.Dictionary")
    
    ' Loop through the mentions and count occurrences
    For i = 1 To mentionsRange.Rows.Count
        mention = mentionsRange.Cells(i, 1).Value
        If mentionDict.exists(mention) Then
            mentionDict(mention) = mentionDict(mention) + 1
        Else
            mentionDict.Add mention, 1
        End If
    Next i
    
    ' Get the sorted list of keys (mentions)
    sortedMentions = mentionDict.Keys
    Call QuickSort(sortedMentions, LBound(sortedMentions), UBound(sortedMentions))
    
    ' Output the grouped mentions and counts to Sheet2
    outputRow = 1
    wsOutput.Cells(outputRow, 1).Value = "Item"
    wsOutput.Cells(outputRow, 2).Value = "Count"
    wsOutput.Cells(outputRow, 3).Value = "Lookup from WB2"
    wsOutput.Cells(outputRow, 4).Value = "Lookup from WB3"
    wsOutput.Cells(outputRow, 5).Value = "Lookup from WB4"
    wsOutput.Cells(outputRow, 6).Value = "Final Combined Result"
    outputRow = outputRow + 1
    
    ' Open Workbook2, Workbook3, and Workbook4
    Set wb2 = Workbooks.Open("C:\path\to\Workbook2.xlsx") ' Update the path to Workbook2
    Set ws2 = wb2.Sheets("Sheet1") ' Update if Workbook2 has a different sheet name
    lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    Set lookupRange2 = ws2.Range("A1:B" & lastRow) ' Lookup range in Workbook2 (A and B)
    
    Set wb3 = Workbooks.Open("C:\path\to\Workbook3.xlsx") ' Update the path to Workbook3
    Set ws3 = wb3.Sheets("Sheet1") ' Update if Workbook3 has a different sheet name
    lastRow = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row
    Set lookupRange3 = ws3.Range("A1:B" & lastRow) ' Lookup range in Workbook3 (A and B)
    
    Set wb4 = Workbooks.Open("C:\path\to\Workbook4.xlsx") ' Update the path to Workbook4
    Set ws4 = wb4.Sheets("Sheet1") ' Update if Workbook4 has a different sheet name
    lastRow = ws4.Cells(ws4.Rows.Count, "A").End(xlUp).Row
    Set lookupRange4 = ws4.Range("A1:B" & lastRow) ' Lookup range in Workbook4 (A and B)
    
    ' Add alphabetic separators and output the sorted data
    currentLetter = ""
    
    For i = LBound(sortedMentions) To UBound(sortedMentions)
        mention = sortedMentions(i)
        firstLetter = UCase(Left(mention, 1))
        
        ' If the first letter of the mention has changed, add a separator row
        If firstLetter <> currentLetter Then
            wsOutput.Cells(outputRow, 1).Value = firstLetter
            wsOutput.Cells(outputRow, 1).Font.Bold = True
            wsOutput.Cells(outputRow, 1).Font.Size = 12
            outputRow = outputRow + 1
            currentLetter = firstLetter
        End If
        
        ' Output the mention and its count
        wsOutput.Cells(outputRow, 1).Value = mention
        wsOutput.Cells(outputRow, 2).Value = mentionDict(mention)
        
        ' Perform the VLOOKUP for this mention in Workbook2
        lookupValue = Trim(CStr(mention)) ' Convert to string and trim spaces
        On Error Resume Next
        lookupResult2 = Application.WorksheetFunction.VLookup(lookupValue, lookupRange2, 2, False)
        On Error GoTo 0
        If IsError(lookupResult2) Then
            lookupResult2 = "#N/A"
        End If
        
        ' Perform the VLOOKUP for this mention in Workbook3
        On Error Resume Next
        lookupResult3 = Application.WorksheetFunction.VLookup(lookupValue, lookupRange3, 2, False)
        On Error GoTo 0
        If IsError(lookupResult3) Then
            lookupResult3 = "#N/A"
        End If
        
        ' Perform the VLOOKUP for this mention in Workbook4
        On Error Resume Next
        lookupResult4 = Application.WorksheetFunction.VLookup(lookupValue, lookupRange4, 2, False)
        On Error GoTo 0
        If IsError(lookupResult4) Then
            lookupResult4 = "#N/A"
        End If
        
        ' Output the individual lookup results in Columns C, D, and E
        wsOutput.Cells(outputRow, 3).Value = lookupResult2
        wsOutput.Cells(outputRow, 4).Value = lookupResult3
        wsOutput.Cells(outputRow, 5).Value = lookupResult4
        
        ' Combine the results
        combinedResult = ""
        If lookupResult2 <> "#N/A" Then combinedResult = lookupResult2
        If lookupResult3 <> "#N/A" Then
            If combinedResult <> "" And combinedResult <> lookupResult3 Then
                combinedResult = combinedResult & " \ " & lookupResult3
            ElseIf combinedResult = "" Then
                combinedResult = lookupResult3
            End If
        End If
        
        If lookupResult4 <> "#N/A" Then
            If combinedResult <> "" And combinedResult <> lookupResult4 Then
                combinedResult = combinedResult & " \ " & lookupResult4
            ElseIf combinedResult = "" Then
                combinedResult = lookupResult4
            End If
        End If
        
        ' If no matches, display #N/A
        If combinedResult = "" Then
            combinedResult = "#N/A"
        End If
        
        ' Output the final combined result in Column E
        wsOutput.Cells(outputRow, 6).Value = combinedResult
        
        outputRow = outputRow + 1
    Next i
    
    ' Close Workbook2, Workbook3, and Workbook4
    wb2.Close False
    wb3.Close False
    wb4.Close False
    
    MsgBox "Mentions have been grouped, sorted, and lookup results combined successfully!", vbInformation
End Sub
' QuickSort algorithm to sort the mentions alphabetically
Sub QuickSort(arr As Variant, low As Long, high As Long)
    Dim pivot As Variant
    Dim i As Long
    Dim j As Long
    Dim temp As Variant
    
    If low < high Then
        pivot = arr((low + high) \ 2)
        i = low
        j = high
        
        Do While i <= j
            Do While arr(i) < pivot
                i = i + 1
            Loop
            Do While arr(j) > pivot
                j = j - 1
            Loop
            
            If i <= j Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
                i = i + 1
                j = j - 1
            End If
        Loop
        
        Call QuickSort(arr, low, j)
        Call QuickSort(arr, i, high)
    End If
End Sub

排查关键点及修复方案 #

1. 脏数据与格式统一处理 #

仅对lookupValue做Trim和转字符串不足以覆盖所有脏数据场景，查找范围中的单元格可能存在前后空格、换行符等非打印字符，导致匹配失败：

• 优化lookupValue的处理逻辑，增加非打印字符清理：

  lookupValue = Application.Clean(Trim(CStr(mention)))
  

• 若查找范围的A列存在隐藏空格，可手动用Excel的TRIM函数批量验证，或在代码中遍历查找范围统一清理。

2. 错误处理逻辑优化 #

使用WorksheetFunction.VLookup配合On Error Resume Next的方式容易出现判断误差，建议改用Application.VLookup（不带WorksheetFunction），它出错时返回错误值而非抛出运行时错误，逻辑更清晰：

' 替换原Workbook2的VLOOKUP代码，其余两个工作簿同理
lookupValue = Application.Clean(Trim(CStr(mention)))
lookupResult2 = Application.VLookup(lookupValue, lookupRange2, 2, False)
If IsError(lookupResult2) Then
    lookupResult2 = "#N/A"
End If

此写法无需On Error Resume Next，避免错误处理带来的意外值残留问题。

3. 排除表头干扰 #

当前lookupRange包含A1表头，虽精确匹配下不影响，但建议从数据行开始构建查找范围，减少不必要的匹配干扰：

' 原代码：Set lookupRange2 = ws2.Range("A1:B" & lastRow)
' 修改为：
Set lookupRange2 = ws2.Range("A2:B" & lastRow)

4. 大小写敏感处理（可选） #

Excel的VLOOKUP默认不区分大小写，若业务需要严格大小写匹配，需改用Application.Match结合Index实现：

Dim matchPos As Variant
matchPos = Application.Match(lookupValue, ws2.Range("A2:A" & lastRow), 0)
If Not IsError(matchPos) Then
    lookupResult2 = ws2.Range("B" & matchPos + 1).Value ' 因从A2开始，需+1偏移
Else
    lookupResult2 = "#N/A"
End If

若无需严格大小写，可统一转换为大写/小写后再匹配：

lookupValue = UCase(Application.Clean(Trim(CStr(mention))))
' 同时确保查找范围的A列值也统一转换（可提前批量处理）

5. 路径与工作表验证 #

确认工作簿路径正确（无空格、特殊字符，或改用相对路径），且打开的工作表是包含查找数据的目标表，避免因路径/表名错误导致查找范围无效。

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