检查单元格的值

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

我有一个包含一些数据（ 400k行，这就是为什么我用variables而不是整数的variables），我想检查列R（其中包含ID的），需要检查然后列S和T.如果R是相同的S和T是不同的，代码应该复制整行并粘贴到另一个表。 代码运行并粘贴一些东西，但不是正确的行。 在此先感谢，任何帮助将不胜感激。

样本数据

 RST 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行不同的方法。 这是我发现最快的一个。

逻辑：

1. 将数据复制到临时表，然后删除重复项。
2. 对数据进行sorting
3. 将结果范围存储在一个数组中
4. 循环和做比赛，并最终复制

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

IMP：由于行数的原因，不能使用自动Autofilter或Autofilter工作表函数。

码：

 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）和行号sorting，
• 将公式=AND(R2=R1,OR(S2<>S1,T2<>T1))到第2行并将其复制到工作表中，
• 筛选以显示所有真实的行
• 将可见行复制到新工作表。

这应该给你更好的性能，更容易维护。