Question

我正在尝试在Excel中执行以下操作：

我有一张包含一些数据（400k行的表格，这就是为什么我长期使用变量而不是整数的原因）我想检查列R（包含ID），然后需要检查列数S和T.如果R相同且S和T不同，则代码应复制整行并将其粘贴到另一个工作表中。代码运行并粘贴一些东西，但不是正确的行。在此先感谢，任何帮助将受到高度赞赏。

样本数据

R           S       T
1234    Kevin   Smith
2345    John    Miller
1234    Carl    Jones
1234    Kevin   Smith
4567    Mike    Redwood
2058    William Wales

代码

Sub mySub1()
    Set wb = ThisWorkbook
    Set tbl = wb.Sheets("sheet1")
    Dim lrow As Long
    Dim i As Long
    Dim x As Long
    Dim y As Long
    Dim cell As Range

    i = 1
    x = 0
    y = 1

    Sheets("sheet1").Activate

    lrow = tbl.Cells(Rows.Count, "A").End(xlUp).Row

    For Each cell In Range("R2:R" & lrow)
        If cell.Offset(x, 0).Value = cell.Offset(i, 0).Value And _
        cell.Offset(0, 1) <> cell.Offset(i, 1).Value And _
        cell.Offset(0, 2).Value <> cell.Offset(i, 2).Value Then
            ActiveSheet.Range(Cells(i + 1, 1), Cells(i + 1, 26)).Select
            Selection.Copy
            Sheets("sheet2").Select
            ActiveSheet.Cells(y, 1).PasteSpecial
            y = y + 1
        End If
        Sheets("sheet1").Activate
        i = i + 1
        x = x + 1
    Next
End Sub

Answer 1

好的我在400k行上尝试了不同的方法。这是我发现最快的那个。

<强>逻辑：

将数据复制到临时表，然后删除重复项。
对数据进行排序
将结果范围存储在数组中
循环并进行匹配，最后复制

我假设Sheet1中的数据没有标题。如果是，则将Header:=xlNo更改为Header:=xlYes并修改for循环。

IMP：由于行数的原因，无法使用Autofilter或Countif等工作表函数。

<强>代码：

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet, wsTemp As Worksheet
    Dim wsILRow As Long, wsOLRow As Long
    Dim rng As Range
    Dim itm As String
    Dim Myar

    Set wsI = ThisWorkbook.Sheets("Sheet1")
    Set wsO = ThisWorkbook.Sheets("Sheet2")
    Set wsTemp = ThisWorkbook.Sheets.Add

    wsOLRow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1

    wsI.Cells.Copy wsTemp.Cells

    With wsTemp
        wsILRow = .Range("R" & .Rows.Count).End(xlUp).Row

        .Range("$R$1:$T$" & wsILRow).RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlNo

        .Columns("A:Z").Sort Key1:=.Range("R1"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

        wsILRow = .Range("R" & .Rows.Count).End(xlUp).Row

        Set rng = .Range("R1:T" & wsILRow)
    End With

    Myar = rng.Value

    For i = 1 To UBound(Myar)

        If i > 1 Then If Myar(i, 1) = Myar(i - 1, 1) Then GoTo NextRec

        itm = Myar(i, 1)
        For j = i + 1 To UBound(Myar)
            If Myar(j, 1) = itm Then
                If Myar(i, 2) & Myar(j, 2) <> Myar(i, 3) & Myar(j, 3) Then
                    wsTemp.Rows(j).Copy wsO.Rows(wsOLRow)
                    wsOLRow = wsOLRow + 1
                End If
            End If
        Next j
NextRec:
    Next i

    Application.DisplayAlerts = False
    wsTemp.Delete
    Application.DisplayAlerts = True
End Sub

Answer 2

如果您不必使用VBA，则可以通过简单的工作表操作来完成此操作。

获取工作表：

附加包含递增行号的列
按ID（列R）和行号
将公式=AND(R2=R1,OR(S2<>S1,T2<>T1))附加到第2行并将其复制到工作表中
过滤以显示所有真实的行和
将可见行复制到新工作表。

这应该会为您提供更好的性能并且更易于维护。

检查单元格的值

2 个答案: