vba - 使用 VBA Excel 将列中的数字与另一列中的相同数字匹配

Question

首先，我想为这个糟糕的问题道歉，我希望它不会让这里的任何人感到不安。由于我不太擅长说英语来表达我的要求，所以请查看引用的链接以获得对这个问题的清晰解释。

我正在尝试寻找 this question of mine 的解决方案.我开始尝试在 A 列和 B 列(借方和贷方)中搜索相同的数字。我使用 looping-trough-array 方法而不是使用 查找 功能类似于 this question因为我认为它更快。

假设我在 Sheet1 中有以下设置数据并从第 1 行列 A 开始:

D e b i t   Cr e d i t
20          13
14          13
13          14
14          17
19          19
11          20
17          14
20          12
19          19
20          15
20          12
13          11
12          19
13          20
19          19
20          11
11          16
10          16
19          19
20          11

现在，我想将上面的数据集处理成这样:



基本上，我需要在特定行中找到相同的借方和贷方值，并将其与另一行中的借方和贷方匹配。 C 列(行)表示匹配值。例如，第 2 行中的借方值与第 15 行中的贷方值匹配，反之亦然。 D 列(ID 匹配)中的数字是标签编号，用于指示首先找到的匹配数据的顺序。这是我试图实现该任务的代码:

Public i As Long, j As Long, k As Long, Last_Row As Long
Public DC, Row_Data, ID_Match
Sub Quick_Match()
T0 = Timer
k = 0
Last_Row = Cells(Rows.Count, "A").End(xlUp).Row

ReDim DC(1 To Last_Row - 1, 1 To 2)
ReDim Row_Data(1 To Last_Row - 1, 1 To 1)
ReDim ID_Match(1 To Last_Row - 1, 1 To 1)
DC = Range("A2:B" & Last_Row)

For i = 1 To Last_Row - 1
    If DC(i, 1) <> "" Then
            k = k + 1
            For j = 1 To Last_Row - 1
                If DC(i, 1) <> DC(i, 2) Then
                    If DC(i, 1) = DC(j, 2) And DC(i, 2) = DC(j, 1) Then
                        Call Row_Label
                        Exit For
                    Else
                        Row_Data(i, 1) = "No Match"
                    End If
                Else
                    If i <> j Then
                        If DC(i, 1) = DC(j, 1) And DC(i, 2) = DC(j, 2) Then
                            Call Row_Label
                            Exit For
                        Else
                            Row_Data(i, 1) = "No Match"
                        End If
                    End If
                End If
            Next j
    End If

    If Row_Data(i, 1) = "No Match" Then
        k = k - 1
    End If

Next i

Range("C2:C" & Last_Row) = Row_Data
Range("D2:D" & Last_Row) = ID_Match
InputBox "The runtime of this program is ", "Runtime", Timer - T0
End Sub

Sub Row_Label()
    Row_Data(i, 1) = j + 1
    ID_Match(i, 1) = k
    Row_Data(j, 1) = i + 1
    ID_Match(j, 1) = k
    DC(i, 1) = ""
    DC(i, 2) = ""
    DC(j, 1) = ""
    DC(j, 2) = ""
End Sub

虽然它的性能有点慢，但它工作得很好。在我的机器上处理 10,000 行数据大约需要 25 秒完成(数据集文件可以下载 on this link 用于测试你的代码和我的代码的运行时间)。所以我想知道是否有更有效的方法来做到这一点。谁能想出一个更短的版本或更快的版本？请分享您的尝试。

Answer 1

我们的 ID 没有什么不同，因为我不会在列表中提前搜索匹配项。我一次遍历列表，将键添加到字典中。如果找到与您的条件匹配的键已存在，则分配新的 ID 和行号。

让我知道这是否符合您的标准。

Sub DebitCreditCrossMatch()

    Dim dictKeys As Object, dictRows As Object
    Dim DebitKey As String, CreditKey As String
    Dim arrDebit, arrCredit, arrMatchRow, arrMatchID, items, keys
    Dim ID As Long, rw As Long, x As Long, lastRow As Long

    lastRow = Cells(Rows.count, "A").End(xlUp).Row

    arrDebit = Range("A1", "A" & lastRow).Value
    arrCredit = Range("B1", "B" & lastRow).Value
    arrMatchRow = Range("C1", "C" & lastRow).Value
    arrMatchID = Range("D1", "D" & lastRow).Value

    Set dictKeys = CreateObject("Scripting.Dictionary")

    For x = 2 To lastRow
        arrMatchRow(x, 1) = "No Match"
        arrMatchID(x, 1) = "No Match"

        DebitKey = arrDebit(x, 1) & ":" & arrCredit(x, 1)

        CreditKey = arrCredit(x, 1) & ":" & arrDebit(x, 1)

        If dictKeys.Exists(CreditKey) Then
            Set dictRows = dictKeys(CreditKey)
            items = dictRows.items
            keys = dictRows.keys
            rw = CLng(items(0))
            ID = ID + 1
            arrMatchRow(x, 1) = rw
            arrMatchRow(rw, 1) = x
            arrMatchID(x, 1) = ID
            arrMatchID(rw, 1) = ID
            dictRows.Remove keys(0)

            If dictRows.count = 0 Then dictKeys.Remove CreditKey

        ElseIf dictKeys.Exists(DebitKey) Then
            Set dictRows = dictKeys(DebitKey)
            dictRows.Add x, x
        Else
            Set dictRows = CreateObject("Scripting.Dictionary")
            dictRows.Add x, x
            dictKeys.Add DebitKey, dictRows
        End If
    Next

    Range("C1", "C" & lastRow).Value = arrMatchRow
    Range("D1", "D" & lastRow).Value = arrMatchID

    Set dictKeys = Nothing
    Set dictRows = Nothing

End Sub