Application.Match无法识别匹配项的VBA排错求助

我编写了一段VBA程序，当指定工作表相关列单元格变更时触发，用于识别同一District（C列）下重复的WO值（D列），排序时将其分组。实现逻辑为：先给辅助列（Order Helper）分配顺序整数，再将同区重复WO的辅助列值改为首个实例的数值，最后按该列排序。但程序运行到给pos赋值时始终报错，已确认WO是重复值且存在于dupArray中，wo和search均为字符串类型。

示例数据 #

原报错代码 #

Public Sub masterWOSort(sheet As String, tb As String)
    With Sheets(sheet)
        Dim wo As String
        Dim tb2 As ListObject
        Set tb2 = .ListObjects(tb)
        Dim count As Integer: count = 0
        Dim t As Long: t = 1
        Dim oc As Integer: oc = 0
        Dim numSave As Integer
        Dim district As String
        For Each rw In tb2.DataBodyRange.Rows    ' put a sequential number next to each row
            rw.Cells(11).Value = t
            t = t + 1
        Next rw
        
        Dim allWo() As Variant
        ReDim allWo(1 To t - 1)
        Dim c As Integer: c = 1
        For Each rw In tb2.DataBodyRange.Rows
            allWo(c) = rw.Cells(4).Value
            c = c + 1
        Next rw
        
    'make unique list of allWo()
        Dim uniqueWO() As Variant
        uniqueWO() = CreateUniqueList(3, t + 1)
        
        Dim dupArray() As String
        Dim j As Integer: j = 1
        Dim z As Integer: z = 1
        Dim i As Integer: i = 1
        'create pasted ranges
        For Each u In uniqueWO()
            'paste to column whatever row j
            .Cells(j, 30).Value = uniqueWO(j)
            j = j + 1
        Next u
        For Each a In allWo()
            'paste to column whatever row j
            .Cells(z, 31).Value = allWo(z)
            z = z + 1
        Next a
 'determine length of uniqueWo() and allWo()
        Dim ulength As Integer
        ulength = UBound(uniqueWO, 1) - LBound(uniqueWO, 1)
        Dim alength As Integer
        alength = UBound(allWo, 1) - LBound(allWo, 1)
'create ranges of uniqueWo and allWo
        Dim uRng As Range
        Dim uString As String
        uString = "AD1:AD" & ulength
        Set uRng = ActiveSheet.Range(uString)
        Dim aRng As Range
        Dim aString As String
        aString = "AE1:AE" & alength
        Set aRng = ActiveSheet.Range(aString)
 'for each value in the pasted range, check how often it appears in allwo(), if multiple times then put in another array
        For counter = 1 To ulength
            If WorksheetFunction.CountIf(aRng, uRng.Cells(counter)) > 1 Then
                ReDim Preserve dupArray(1, 1 To i)
                dupArray(0, i) = uniqueWO(counter)
                dupArray(1, i) = 0
                i = i + 1
            End If
        Next counter
        
        
        Dim pos As Variant
        Dim search As String
        For Each rw In tb2.DataBodyRange.Rows    ' replace number with the one of the first instance of WO if it is a multiple
            wo = rw.Cells(4).Value
            If IsInArray(wo, dupArray) = True Then
                For z = 1 To UBound(dupArray, 2)
                    On Error Resume Next
                    search = Application.Index(dupArray, 1, z)
                    pos = Application.Match(wo, search, 0)
                    
                    On Error Resume Next
                    dupArray(1, pos) = dupArray(1, pos) + 1
                    If IsError(pos) = False Then Exit For
                Next
                If dupArray(1, pos) = 1 Then
                numSave = rw.Cells(11).Value
                district = rw.Cells(3).Value
                    ElseIf rw.Cells(3).Value = district Then
                        rw.Cells(11).Value = numSave
                End If
            End If
        Next rw
 'delete helper columns for allWo and uniqueWo
        .Columns(30).ClearContents
        .Columns(31).ClearContents
        
    End With
End Sub

Function CreateUniqueList(nStart As Long, nEnd As Long) As Variant
 Dim Col As New Collection
 Dim arrTemp() As Variant
 Dim valCell As String
 Dim i As Integer
 'Populate Temporary Collection
  On Error Resume Next
  For i = 0 To nEnd
  valCell = Range("D" & nStart).Offset(i, 0).Value
  Col.add valCell, valCell
 Next i
 Err.Clear
 On Error GoTo 0
  'Resize n
   nEnd = Col.count
  'Redeclare array
   ReDim arrTemp(1 To nEnd)
  'Populate temporary array by looping through the collection
   For i = 1 To Col.count
     arrTemp(i) = Col(i)
   Next i
  'return the temporary array to the function result
   CreateUniqueList = arrTemp()
End Function

Public Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
 Dim i
 For i = LBound(arr, 2) To UBound(arr, 2)
    If arr(0, i) = stringToBeFound Then
        IsInArray = True
        Exit Function
    End If
 Next i
 IsInArray = False
End Function

错误原因分析 #

1. Application.Match使用错误：search = Application.Index(dupArray, 1, z)返回单个字符串，而Match需要数组/单元格区域作为查找范围，导致匹配逻辑失效。
2. 数组索引混乱：dupArray定义为二维数组，但IsInArray中使用arr(0, i)访问，与实际数组维度（第一维索引为1）不匹配，导致判断错误或越界。
3. 未限定工作表对象：CreateUniqueList中Range("D" & nStart)未指定工作表，可能引用错误工作表的数据。
4. 未区分同WO不同District的情况：原逻辑仅判断WO重复，未结合District，会导致不同区域的同WO被错误分组。

优化修复方案（推荐使用字典简化逻辑） #

用Dictionary存储每个District+WO组合的首个辅助列值，彻底避免数组匹配错误，代码更简洁高效：

Public Sub masterWOSort(sheet As String, tb As String)
    With Sheets(sheet)
        Dim wo As String
        Dim tb2 As ListObject
        Set tb2 = .ListObjects(tb)
        Dim t As Long: t = 1
        Dim currentDistrict As String
        Dim firstOccurrence As Dictionary
        
        ' 初始化字典，存储每个(District, WO)组合的首个辅助列值
        Set firstOccurrence = New Dictionary
        firstOccurrence.CompareMode = vbTextCompare ' 按需设置是否区分大小写
        
        ' 第一步：给辅助列分配顺序整数，同时记录首个实例值
        For Each rw In tb2.DataBodyRange.Rows
            rw.Cells(11).Value = t
            currentDistrict = rw.Cells(3).Value
            wo = rw.Cells(4).Value
            Dim key As String
            key = currentDistrict & "|" & wo ' 组合键区分同WO不同区域
            If Not firstOccurrence.Exists(key) Then
                firstOccurrence.Add key, t
            End If
            t = t + 1
        Next rw
        
        ' 第二步：替换同区重复WO的辅助列值为首个实例值
        For Each rw In tb2.DataBodyRange.Rows
            currentDistrict = rw.Cells(3).Value
            wo = rw.Cells(4).Value
            Dim lookupKey As String
            lookupKey = currentDistrict & "|" & wo
            If firstOccurrence.Exists(lookupKey) Then
                rw.Cells(11).Value = firstOccurrence(lookupKey)
            End If
        Next rw
        
    End With
End Sub

优化说明 #

• 用字典替代复杂的数组操作，彻底解决匹配报错问题。
• 用District|WO作为组合键，确保仅同一区域的重复WO才会被分组。
• 移除冗余的临时列操作，提升代码运行效率。

原代码针对性修复（保留数组逻辑） #

如果必须保留原数组思路，可针对错误点修正：

Public Sub masterWOSort(sheet As String, tb As String)
    With Sheets(sheet)
        Dim wo As String
        Dim tb2 As ListObject
        Set tb2 = .ListObjects(tb)
        Dim t As Long: t = 1
        Dim numSave As Integer
        Dim district As String
        
        ' 给辅助列分配顺序整数
        For Each rw In tb2.DataBodyRange.Rows
            rw.Cells(11).Value = t
            t = t + 1
        Next rw
        
        Dim allWo() As Variant
        ReDim allWo(1 To t - 1)
        Dim c As Integer: c = 1
        ' 存储District+WO组合键
        For Each rw In tb2.DataBodyRange.Rows
            allWo(c) = rw.Cells(3).Value & "|" & rw.Cells(4).Value
            c = c + 1
        Next rw
        
        ' 生成唯一组合键列表
        Dim uniqueWO() As Variant
        uniqueWO = CreateUniqueList(.Name, tb2.DataBodyRange.Columns(3).Row, tb2.DataBodyRange.Rows.Count)
        
        Dim dupArray() As String
        Dim i As Integer: i = 1
        ' 标记重复的组合键
        For counter = 1 To UBound(uniqueWO)
            If WorksheetFunction.CountIf(allWo, uniqueWO(counter)) > 1 Then
                ReDim Preserve dupArray(1 To i)
                dupArray(i) = uniqueWO(counter)
                i = i + 1
            End If
        Next counter
        
        ' 记录每个组合键的首个辅助列值
        Dim firstValue As Dictionary
        Set firstValue = New Dictionary
        For Each rw In tb2.DataBodyRange.Rows
            Dim key As String
            key = rw.Cells(3).Value & "|" & rw.Cells(4).Value
            If Not firstValue.Exists(key) Then
                firstValue.Add key, rw.Cells(11).Value
            End If
        Next rw
        
        ' 替换重复组合键的辅助列值
        For Each rw In tb2.DataBodyRange.Rows
            Dim currentKey As String
            currentKey = rw.Cells(3).Value & "|" & rw.Cells(4).Value
            If IsInArray(currentKey, dupArray) Then
                rw.Cells(11).Value = firstValue(currentKey)
            End If
        Next rw
        
    End With
End Sub

Function CreateUniqueList(sheetName As String, nStart As Long, rowCount As Long) As Variant
 Dim Col As New Collection
 Dim arrTemp() As Variant
 Dim valCell As String
 Dim i As Integer
 On Error Resume Next
 With Sheets(sheetName)
     For i = 0 To rowCount - 1
         valCell = .Cells(nStart + i, 3).Value & "|" & .Cells(nStart + i, 4).Value
         Col.Add valCell, valCell
     Next i
 End With
 Err.Clear
 On Error GoTo 0
 ReDim arrTemp(1 To Col.Count)
 For i = 1 To Col.Count
     arrTemp(i) = Col(i)
 Next i
 CreateUniqueList = arrTemp
End Function

Public Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
 Dim i
 For i = LBound(arr) To UBound(arr)
    If arr(i) = stringToBeFound Then
        IsInArray = True
        Exit Function
    End If
 Next i
 IsInArray = False
End Function

修复说明 #

• 修正数组索引逻辑，改用一维数组存储组合键。
• 限定Range对象的工作表，避免引用错误数据。
• 用组合键区分同WO不同区域的情况，符合需求。

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