Application.Match 无法识别匹配项

Question

拥有这个冗长而复杂的程序，当给定工作表上相关列中的单元格发生更改时调用，目的是识别 WO 值（D 列）中存在重复项的情况，并将它们保持在一起，同时按其他值排序（作为我正在实施的一般排序规则的例外），只要它们的区值（c 列）相同。我尝试执行此操作的方法是使用辅助列，其中（在完成所有其他排序之后）我按顺序为每行分配一个整数，然后如果程序看到重复的 WO 值，其中区域也相同，它将辅助列值更改为与该地区中该 WO 的第一个实例相同的数字，然后工作表将按该列最后排序。

该程序似乎按预期工作，直到我尝试为 pos 分配一个值，并且它总是出现错误，即使 WO 是重复的并且我已经验证它位于 dupArray 中。我还验证了 wo 和 search 都是字符串。

编辑：添加正在排序的数据示例表，相关列是 District、WO# 和 Order Helper（帮助列）。在此示例中，虽然表主要按地区和优先级排序，但由于洛杉矶有 2 个 WO# 123 实例，因此第二个实例的顺序辅助值从 5 重新分配为 3，然后重新排序，因此它保持分组状态与另一个实例。

截止日期	距到期日	区	WO#	已分配	设施	描述	优先	额外	收到日期	订单帮手
2024-11-22	逾期	纽约	123	是的	n/a	n/a	A		2024 年 10 月 1 日	1
2024-12-26	0	纽约	345	没有	n/a	n/a	B		2024 年 10 月 1 日	2
2024-11-26	逾期	洛杉矶	123	没有	n/a	n/a	A		2024 年 10 月 1 日	3
2024-11-26	逾期	洛杉矶	123	没有	n/a	n/a	B		2024 年 10 月 1 日	3
2024-11-22	逾期	洛杉矶	678	没有	n/a	n/a	A		2024 年 10 月 1 日	4

    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 seRuential 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

Answer 1

通过两个

For...Next

循环，代码遍历表格的行，并收集特定单元格（District 和 WO#）上的相同行。

Sub Order(sheet As String, table As String)
Dim sh As Worksheet
Set sh = Worksheets(sheet)
Dim dbr As Range
Set dbr = sh.ListObjects(table).DataBodyRange
For base = 1 To dbr.Rows.count - 1
    baserun = base + 1
    For runpoi = baserun To dbr.Rows.count
        If dbr.Cells(base, 3) = dbr.Cells(runpoi, 3) And dbr.Cells(base, 4) = dbr.Cells(runpoi, 4) Then
            dbr.Rows(runpoi).Cut
            dbr.Rows(base + 1).Insert
            base = base + 1
        End If
    Next runpoi
Next base
End Sub