检查单元格的值(Checking values of cells)

检查单元格的值(Checking values of cells)

我想在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

I am trying to do the following in Excel:

I have a sheet with some data (400k rows, which is why I used long for the variables instead of integers) and I want to check Column R (which contains ID's) and need to check then against Columns S and T. If R is the same and S and T is different, the code should copy the entire row and paste it in another sheet. The code runs and pastes something but not the correct rows. Thanks in advance, any help would be highly appreciated.

Sample Data

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

Code

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

最满意答案

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

逻辑：

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

我假设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

Ok I tried different methods on 400k rows. This is the one which I found the fastest.

Logic:

Copy the data to a temp sheet and then remove duplicates. Sort the data Store the resulting range in an array Loop and do the match and finally copy

I am assuming that the data in Sheet1 doesn't have headers. If it does then change Header:=xlNo to Header:=xlYes and modify the for loops.

IMP: Can't use Autofilter or worksheet functions like Countif because of the number of rows.

Code:

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