Question

我正在使用循环在Excel上编写VBA代码，以通过 10000+行。

以下是表格的示例

以下是我写的代码：

Sub Find_Matches()

    Dim wb As Workbook
    Dim xrow As Long

    Set wb = ActiveWorkbook
    wb.Worksheets("Data").Activate

    tCnt = Sheets("Data").UsedRange.Rows.Count
    Dim e, f, a, j, h As Range
    xrow = 2

    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    For xrow = 2 To tCnt Step 1
        Set e = Range("E" & xrow)
        Set f = e.Offset(0, 1)
        Set a = e.Offset(0, -4)
        Set j = e.Offset(0, 5)
        Set h = e.Offset(0, 3)
        For Each Cell In Range("E2:E" & tCnt)
            If Cell.Value = e.Value Then
                If Cell.Offset(0, 1).Value = f.Value Then
                    If Cell.Offset(0, -4).Value = a.Value Then
                        If Cell.Offset(0, 5).Value = j.Value Then
                            If Cell.Offset(0, 3).Value = h.Value Then
                                If (e.Offset(0, 7).Value) + (Cell.Offset(0, 7).Value) = 0 Then
                                    Cell.EntireRow.Interior.Color = vbYellow
                                    e.EntireRow.Interior.Color = vbYellow
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        Next
    Next
End Sub

您可以想象，这需要花费大量时间来完成10000多行，我希望找到更快的解决方案。必须有一种方法我不认为可以避免过度循环

以下是条件：

对于每一行，如果文件中任何位置的另一行具有完全相同的行   ：


买方ID（col.E）

`#cored（col.F）

产品编号（col.A）

付款（col.J）

购买日期（col.H）


然后，如果Amount（col.L）的和，那两个匹配的行是   0，然后将这两行染成黄色。

请注意，额外的列存在且未进行比较（例如B），但对于文档仍然很重要，无法删除以简化过程。

运行上一段代码，在我的例子中，第2行和第2行5突出显示：

Answer 1

我建议完全采用不同的方法：在数据中添加一个临时列，其中包含行中每个单元格的串联。这样，你有：

A|B|C|D|E
1|Mr. Smith|500|A|1Mr. Smith500A

然后在临时列上使用Excel的条件格式，突出显示重复值。你有重复的行。现在只需要使用过滤器来检查哪些数量等于零。

您可以使用CONCATENATE功能;它需要你单独指定每个单元格，你不能使用范围，但在你的情况下（只比较一些列），这似乎是一个很好的选择。

Answer 2

这是使用嵌套字典和数组来检查所有条件

带有我的测试数据的计时器： Rows: 100,001; Dupes: 70,000 - Time: 14.217 sec

Option Explicit

Public Sub FindMatches()
    Const E = 5, F = 6, A = 1, J = 10, H = 8, L = 12

    Dim ur As Range, x As Variant, ub As Long, d As Object, found As Object

    Set ur = ThisWorkbook.Worksheets("Data").UsedRange
    x = ur
    Set d = CreateObject("Scripting.Dictionary")
    Set found = CreateObject("Scripting.Dictionary")

    Dim r As Long, rId As String, itm As Variant, dupeRows As Object

    For r = ur.Row To ur.Rows.Count
        rId = x(r, E) & x(r, F) & x(r, A) & x(r, J) & x(r, H)
        If Not d.Exists(rId) Then
            Set dupeRows = CreateObject("Scripting.Dictionary")
            dupeRows(r) = 0
            Set d(rId) = dupeRows
        Else
            For Each itm In d(rId)
                If x(r, L) + x(itm, L) = 0 Then
                    found(r) = 0
                    found(itm) = 0
                End If
            Next
        End If
    Next
    Application.ScreenUpdating = False
    For Each itm In found
        ur.Range("A" & itm).EntireRow.Interior.Color = vbYellow
    Next
    Application.ScreenUpdating = True
End Sub

在

Answer 3

Maciej的答案很容易实现（如果您可以在不中断任何内容的情况下为数据添加列），我会尽可能推荐它。

但是，为了回答您的问题，我也将提供VBA解决方案。我在比你小一点的数据集上测试了它，但我认为它对你有用。请注意，您可能需要稍微调整一下（您开始使用哪一行，表名等）以适合您的工作簿。

最值得注意的是，该细分市场评论了＆＃34; Helper专栏＆＃34;你最有可能需要调整的东西 - 目前，它比较当前行的A和H之间的每个单元格，这是你可能想要或不想要的。

我试图在代码中加入一些评论，但并不多。主要的变化是我使用数组的内存处理而不是迭代工作表范围（对于较大的数据集应该以指数方式加快）。

android:id="@+id/textviewid"

在我的简单数据集上，它产生了这个结果（用自由绘制的颜色指示器很好地标记）：

Answer 4

感谢大家的回答，

Paul Bica的解决方案确实有效，我现在正在使用此代码的一个版本。

但是，为了激发辩论的动态，我想我还找到了另一种绕过我的第一个代码的方法，受到Maciej关于连接单元格和使用 CStr的想法的启发通过使用数组而不是通过工作簿来比较值，当然还有Vegard的内存中处理：

Sub Find_MatchesStr()

    Dim AmountArr(300) As Variant
    Dim rowArr(300) As Variant
    Dim ws As Worksheet
    Dim wb As Workbook
    Set ws = ThisWorkbook.Sheets("Data")
    ws.Activate
    Range("A1").Select

    rCnt = ws.Cells.SpecialCells(xlCellTypeLastCell).Row

    For i = 2 To rCnt
        If i = rCnt Then
            Exit For
        Else
        intCnt = 0
        strA = ws.Cells(i, 1).Value
        strE = ws.Cells(i, 5).Value
        strF = ws.Cells(i, 6).Value
        strH = ws.Cells(i, 8).Value
        strL = ws.Cells(i, 10).Value

        For j = i To rCnt - 1
            strSearchA = ws.Cells(j, 1).Value
            strSearchE = ws.Cells(j, 5).Value
            strSearchF = ws.Cells(j, 6).Value
            strSearchH = ws.Cells(j, 8).Value
            strSearchL = ws.Cells(j, 10).Value

            If CStr(strE) = CStr(strSearchE) And CStr(strA) = CStr(strSearchA) And CStr(strF) = CStr(strSearchF) And CStr(strH) = CStr(strSearchH) And CStr(strL) = CStr(strSearchL) Then

                AmountArr(k) = ws.Cells(j, 12).Value
                rowArr(k) = j
                intCnt = intCnt + 1
                k = k + 1
            Else
                Exit For
            End If
        Next
        strSum = 0
        For s = 0 To UBound(AmountArr)
            If AmountArr(s) <> "" Then
                strSum = strSum + AmountArr(s)
            Else
                Exit For
            End If
        Next
        strAppenRow = ""
        For b = 0 To UBound(rowArr)
            If rowArr(b) <> "" Then
                strAppenRow = strAppenRow & "" & rowArr(b) & "," & AmountArr(b) & ","
            Else
                Exit For
            End If
        Next

        If intCnt = 1 Then

        Else
            If strSum = 0 Then
                For rn = 0 To UBound(rowArr)
                    If rowArr(rn) <> "" Then
                        Let rRange = rowArr(rn) & ":" & rowArr(rn)
                        Rows(rRange).Select
                        Selection.Interior.Color = vbYellow
                    Else
                        Exit For
                    End If
                Next
            Else
                strvar = ""
                strvar = Split(strAppenRow, ",")
                For ik = 1 To UBound(strvar)
                    If strvar(ik) <> "" Then
                        strVal = CDbl(strvar(ik))
                        For ik1 = ik To UBound(strvar)
                            If strvar(ik1) <> "" Then
                                strVal1 = CDbl(strvar(ik1))
                                If strVal1 + strVal = 0 Then
                                    Let sRange1 = strvar(ik - 1) & ":" & strvar(ik - 1)
                                    Rows(sRange1).Select
                                    Selection.Interior.Color = vbYellow
                                    Let sRange = strvar(ik1 - 1) & ":" & strvar(ik1 - 1)
                                    Rows(sRange).Select
                                    Selection.Interior.Color = vbYellow
                                End If
                            Else
                                Exit For
                            End If
                            ik1 = ik1 + 1
                        Next
                    Else
                        Exit For
                    End If
                    ik = ik + 1
                Next
            End If
        End If
        i = i + (intCnt - 1)
        k = 0
        Erase AmountArr
        Erase rowArr
        End If
    Next
    Range("A1").Select

End Sub

我仍然有一些错误（当它们应该是没有突出的行时），上面的代码并不完美，但我认为可以让你知道我在保罗比卡之前的去向＆＃39解决方案进来了。

再次感谢！

Answer 5

如果您的数据仅在L列之前，那么使用下面的代码，我发现它运行的时间更短....

Sub Duplicates()
    Application.ScreenUpdating = False
    Dim i As Long, lrow As Long
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("O2") = "=A2&E2&F2&J2&L2"
    Range("P2") = "=COUNTIF(O:O,O2)"
    Range("O2:P" & lrow).FillDown
    Range("O2:O" & lrow).Copy
    Range("O2:O" & lrow).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    For i = 1 To lrow
        If Cells(i, 16) = 2 Then
            Cells(i, 16).EntireRow.Interior.Color = vbYellow
        End If
    Next
    Application.ScreenUpdating = True
    Range("O:P").Delete
    Range("A1").Select
    MsgBox "Done"
End Sub

Excel VBA中的加速匹配程序

5 个答案: