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

虽然它的性能有点慢，但它运行正常。它在我的机器上大约25秒完成，用于处理10,000行数据（可以下载数据集文件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

Answer 2

编辑注释：在没有lctrRow的情况下启动内部循环不会进行反向检查。恢复原始代码。

Sub test()

    '/ Assuming that on Sheet1 starting at A1, four headers are : Debit   Credit  Row   ID Match


    Dim lCtrRow         As Long
    Dim lCtrRow2        As Long
    Dim lmatchCount     As Long

    Dim arrResult

    arrResult = Sheet1.UsedRange

    '/ Loop through first column Rows
    For lCtrRow = LBound(arrResult) To UBound(arrResult)
        lmatchCount = 0
        arrResult(lCtrRow, 3) = "No Match"

        '/ Re-Loop but this time match if A&B = B&A
        For lCtrRow2 = LBound(arrResult) + 1 To UBound(arrResult)
            If arrResult(lCtrRow, 1) & arrResult(lCtrRow, 2) = arrResult(lCtrRow2, 2) & arrResult(lCtrRow2, 1) Then
                '/ If no match then only put down the row number. Avoids overwriting.
                If arrResult(lCtrRow, 3) = "No Match" Then
                    arrResult(lCtrRow, 3) = lCtrRow2
                End If

                '/ Keep track of no. matches found.
                lmatchCount = lmatchCount + 1
                arrResult(lCtrRow, 4) = lmatchCount
            End If
        Next
    Next


      '/ Dump the processed result back on  another sheet
      Sheet2.Range("a1").Resize(UBound(arrResult), UBound(arrResult, 2)) = arrResult

 End Sub

Answer 3

假设Credit-Debit对中没有重复，您可以在一个单独的模块中使用以下方法调用matchCreditDebit（）并根据需要在初始化阶段调整范围：

            Option Explicit

    Public Sub matchCreditDebit()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim debit As Range, credit As Range, match As Range, rows As Long

    rows = ws.UsedRange.rows.Count
    Set credit = ws.Range("A1:A" & rows)
    Set debit = ws.Range("B1:B" & rows)
    Set match = ws.Range("C1:C" & rows)

    match.Offset(1).Clear 'delete previous matched, start with clean slate, offset used to preserve header

    Dim foundRanges As Collection, i As Long, r As Range

    For i = 2 To rows
        If Len(ws.Cells(i, match.Column).Value) = 0 _
        And Len(ws.Cells(i, credit.Column).Value) > 0 Then  'check if match is already found and credit has value

            Set foundRanges = FindAllInRange(debit, credit.Cells(i, 1).Value) 'first sift, find matching debit with a credit value

            If Not foundRanges Is Nothing Then
                For Each r In foundRanges
                    Debug.Print r.Address, ws.Cells(r.Row, credit.Column).Value
                    If ws.Cells(r.Row, credit.Column).Value = ws.Cells(i, debit.Column) Then 'second sift, match for found credit in debit
                        ws.Cells(r.Row, match.Column).Value = i
                    End If
                Next r
            End If
        End If
    Next i

    End Sub

    Public Function FindAllInRange( _
        ByRef searchRange As Range, _
        ByVal FindWhat As Variant _
    ) As Collection
    Dim result As Collection

        Set result = New Collection

        Dim nextFound As Range
        Set nextFound = searchRange.Cells(searchRange.rows.Count, 1)

        Do
            Set nextFound = searchRange.Find( _
                    What:=FindWhat, _
                    After:=nextFound, _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows)

            If nextFound Is Nothing Then Exit Do
            If collectionContainsRange(result, nextFound) Then Exit Do

            result.Add nextFound, nextFound.Address
        Loop While True
        Set FindAllInRange = result
    End Function

    Private Function collectionContainsRange(ByRef result As Collection, ByRef rng As Range) As Boolean
    collectionContainsRange = False

        Dim r As Range
        For Each r In result
            If StrComp(r.Address, rng.Address, vbTextCompare) = 0 Then
                collectionContainsRange = True
                Exit Function
            End If
        Next r
    End Function

一般来说，这样做是找到与第一个标准相匹配的范围，并将它们放入一个集合中，然后筛选出与第二个标准相匹配的范围。但是，如果存在重复对，则最后找到的反向对将作为参考输入

Answer 4

这对我有用：

Sub Matching()

    Dim rng, arr, r1 As Long, r2 As Long, nR As Long
    Dim sortId As Long, rwTrack(), s1, s2

    'get the input range
    With Range("a1").CurrentRegion 'assumes no blank columns/rows
        Set rng = .Offset(1, 0).Resize(.Rows.Count - 1)
    End With

    arr = rng.Value
    nR = UBound(arr, 1)
    ReDim rwTrack(1 To nR) 'for matching row numbers to sortId
                           '  (should be more like nR/2 but lazy...)
    sortId = 1

    For r1 = 1 To nR
        For r2 = r1 + 1 To nR
            If arr(r1, 1) = arr(r2, 2) And arr(r1, 2) = arr(r2, 1) Then
                s1 = arr(r1, 4)
                s2 = arr(r2, 4)
                If Len(s1) = 0 And Len(s2) = 0 Then
                    'new match - assign new Id
                    arr(r1, 4) = sortId
                    arr(r2, 4) = sortId
                    rwTrack(sortId) = r1 & "," & r2 'capture the rows
                    sortId = sortId + 1
                Else
                    'already matched: copy the existing Id and track rows
                    If Len(s1) > 0 And Len(s2) = 0 Then
                        arr(r2, 4) = s1
                        rwTrack(s1) = rwTrack(s1) & "," & r2
                    End If
                    If Len(s2) > 0 And Len(s1) = 0 Then
                        arr(r1, 4) = s2
                        rwTrack(s2) = rwTrack(s2) & "," & r1
                    End If
                End If
            End If
        Next r2
    Next r1
    'populate all of the matched row numbers
    For r1 = 1 To nR
        If arr(r1, 4) <> "" Then arr(r1, 3) = rwTrack(arr(r1, 4))
    Next r1

    'dump the data back
    Range("a1").Offset(1, 0).Resize(nR, UBound(arr, 2)).Value = arr

End Sub

之前和之后：

Answer 5

为了加快匹配，可以提高通过算法。假设你的代码工作正常。

1）我们可以对A列进行排序，然后对B列进行排序，因此，您的数据将是这样的

Row   A    B
2     20   13
3     20   12
4     20   11
.
.
. 
998   13   20
999   12   20
1000  11   20
.
.
.

2）循环借记列以查找Credit列中的第一个值20可能会有非常大的差距。然后我们可以添加application.Match(20,Range("B:B"),0)来找出开始循环的行。

基于上述假设，我们可以减少约1000次循环。（在实际情况下，它可能更多/更少）。 Application.Match()比逐个循环要快得多。

3）退出循环，当Credit值小于Debit值时，因为我们按顺序对数据进行排序，我们可以假设没有可能的匹配，当Credit＆lt;借方。

4）使用Application.ScreenUpdating = False时，可以提高处理速度。

5）不触摸原始数据，也可以使用Application.Match逐行减少。假设你有10K记录，

首先将searchRng设置为C1：C10000，然后匹配以查找第一个借记值的行（20，基于yr照片），

然后我们在第7行找到匹配的记录，检查记录是否与Debit＆amp;信用，如果没有将searchRng的大小减小到C8：C10000则继续重复逻辑

Sub Match ()
   For nRow = 2 to lastRow 'Loop for each row in Column A
       set searchRng = Range("C1:C10000")
       debitVal = Cells(nRow, "B")

       Do until searchRng is Nothing
          If IsError(Application.Match(debitVal, searchRng, 0)) then
            'No Match
            Exit Do
          Else
             N = Application.Match(debitVal, searchRng, 0)
             'Do something to check if Record match, and assign ID Match
             If IsRecordMatched Then
                'Assign ID
                'Matching Range - Cells(nRow,"B")
                'Matched Range - Cells(searchRng.Cells(1).Offset(N,0).Rows, "B")
             Else
                'Resize the searchRng
                nSize = searchRng.Cells.Count - (N + 1)
                if nSize < 1 then Exit Do
                set searchRng = searchRng.Resize(nSize,1)
                set searchRng = searchRng.Offset(N + 1,0)
             End If
          End If
       Loop
   Next nRow
End Sub

以上代码未经测试。请以此为参考。

Answer 6

<强>改进

以下代码的平均完成时间小于 2.4秒。它比前一个快两倍，也更短。

Sub Quick_Match()
Dim i As Long, j As Long, k As Long, Last_Row As Long
Dim DC, Row_Data, ID_Match
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).Value2

For i = 1 To Last_Row - 2
    If DC(i, 1) <> vbNullString Then
            k = k + 1
            For j = i + 1 To Last_Row - 1
            If DC(j, 2) <> vbNullString Then
                If DC(i, 1) = DC(j, 2) And DC(i, 2) = DC(j, 1) Then
                    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) = vbNullString: DC(i, 2) = vbNullString
                    DC(j, 1) = vbNullString: DC(j, 2) = vbNullString
                    Exit For
                End If
            End If
            Next j
    End If

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

Range("C2:C" & Last_Row) = Row_Data
Range("D2:D" & Last_Row) = ID_Match
End Sub

[旧答案]取得了一些进展。以下代码在我的机器上处理10,000行数据时，平均完成时间小于 5.2秒。不仅速度更快，而且比前一个更短。我改变了循环算法以改善其性能。我也使用一些加速技巧，比如使用.Value2而不是默认属性（.Value），使Excel处理更少，并分配vbNullString而不是零长度字符串（＆＃34;＆＃34 ;）找到匹配或标记为＆＃34; No Match＆＃34;的数组元素。这样循环程序不会再次处理它。

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).Value2

For i = 1 To Last_Row - 1
    If DC(i, 1) <> vbNullString Then
            k = k + 1
            For j = 1 To Last_Row - 1
            If DC(j, 2) <> vbNullString Then
                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
                    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
                        End If
                    End If
                End If
            End If
            Next j
    End If

    If Row_Data(i, 1) = vbNullString Then
        Row_Data(i, 1) = "No Match"
        DC(i, 2) = vbNullString
        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, 2) = vbNullString
    DC(j, 1) = vbNullString
    DC(j, 2) = vbNullString
End Sub

Answer 7

我重复了之前的回答，引入了第二个循环;这样我们的身份证号码就会匹配。

public function getActiveProducts() {
        $all_products = $this->hasMany(Product::className(),['product_category_id' => 'id'])->select(['id'])->where(['status'=>1])->all();
        return $all_product;
}
public function getProductsCount() {
        return sizeof($this->activeProducts);
}

使用VBA Excel匹配另一列中具有相同编号的列中的数字

首先，我想为这个可怜的问题道歉，我希望这不会让任何人感到不安。由于我不善于说英语以表达我的要求，所以请查看引用的链接，以便对此问题得到明确的解释。

7 个答案: