Excel VBA - 比较两张不同工作表中的两列，然后复制/粘贴 - 速度 - 需要一个多小时
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/45843106/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel VBA - Compare two Columns in two different sheets then copy/paste - speed - It takes over an hour
提问by TheCricket
Here an absolute beginner at any form of coding, this is the first time ever I try to use VBA.
这是任何形式编码的绝对初学者，这是我第一次尝试使用 VBA。
I have managed after a week and a half of searching and testing and learning to reach the below posted code and I have hit a WALL (and I'm not even done yet!)
经过一个半星期的搜索、测试和学习，我已经完成了下面发布的代码，但我已经碰壁了（我什至还没有完成！）
What I am trying to achieve:
我正在努力实现的目标：
Compare the data in sheet1 with the data in sheet2 found in Columns K respectively A (there are ca. 55.000 rows in K and 2500 in A) the data might repeat itself as these are product codes and it's ok as at the end of this I want to be able to see which ones have expired.
将 sheet1 中的数据与在 K 列中找到的 sheet2 中的数据分别进行比较 A（K 中有大约 55.000 行，A 中有大约 2500 行）数据可能会重复，因为这些是产品代码，并且在最后我可以希望能够看到哪些已经过期。
so .. If K = A then it has to copy adjacent values found in Sheet2 - columns O, P & Q and Paste them in Sheet2 - Columns O, P & Q and if no match is found then right not found. In the Example below I have only tried to copy Q, it would probably take forever if I tried adding O & P.
所以.. 如果 K = A 那么它必须复制在 Sheet2 中找到的相邻值 - 列 O、P & Q 并将它们粘贴到 Sheet2 - 列 O、P & Q 中，如果没有找到匹配项，则没有找到。在下面的示例中，我只尝试复制 Q，如果我尝试添加 O&P，可能需要很长时间。
(Note: I have found this code in one of the forms here and used it after trying different other ways with select/ Copy/ Paste etc. but none have worked)
（注意：我在此处的其中一种形式中找到了此代码，并在尝试使用选择/复制/粘贴等不同的其他方式后使用了它，但都没有奏效）
Later I would like to try adding another column in Sheet1 and based on the Date which will be copied to Sheet1 and into column P populate it with Expired or Soon to be expired depending on the case, but this is an entire different story and I haven't even begun thinking how to do it.
后来我想尝试在 Sheet1 中添加另一列，并根据将被复制到 Sheet1 和 P 列的日期，根据情况用 Expired 或 Soon to be expired 填充它，但这是一个完全不同的故事，我没有甚至没有开始思考如何去做。
The problem is that my current code takes over an hour and it's still not finished yet while I am writing this!!! And I do not understand where have I gone wrong ....
问题是我当前的代码需要一个多小时，而且在我写这个的时候还没有完成！！！而且我不明白我哪里出错了......
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim tempVal As String
lastRow1 = Sheets("Sheet1").Range("K" & Rows.Count).End(xlUp).Row
lastRow2 = Sheets("Sheet2").Range("A" & Rows.Count).Row
For sRow = 2 To lastRow1
tempVal = Sheets("MatCode").Cells(sRow, "A").Text
For tRow = 2 To lastRow2
If Sheets("Sheet1").Cells(tRow, "K") = tempVal Then
Sheets("Sheet1").Cells(tRow, "Q") = Sheets("Sheet2").Cells(sRow, "Q")
End If
Next tRow
Next sRow
Dim match As Boolean
'now if no match was found, then put NO MATCH in cell
For lRow = 2 To lastRow2
match = False
tempVal = Sheets("Sheet1").Cells(lRow, "K").Text
For sRow = 2 To lastRow1
If Sheets("Sheet2").Cells(sRow, "A") = tempVal Then
match = True
End If
Next sRow
If match = False Then
Sheets("Sheet1").Cells(lRow, "Q") = "NO MATCH"
End If
Next lRow
End Sub
I have also used:
我也用过：
With Application
.AskToUpdateLinks = False
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
To make sure nothing stands in the way.
以确保没有任何障碍。
Please Help!
请帮忙！
回答by mooseman
This will loop through rows to match column A on Sheet1 with column K on sheet2. On a non-match "No Match" will be put in Sheet1 column Q. On a match Sheet2 columns O,P and Q will be copied to Sheet1 columns O,P and Q. This took about 10 seconds to run for over 12k in column A and over 2500 in column K.
这将遍历行以将 Sheet1 上的 A 列与 sheet2 上的 K 列进行匹配。在不匹配的情况下，“无匹配”将放入 Sheet1 列 Q。在匹配时，Sheet2 列 O、P 和 Q 将复制到 Sheet1 列 O、P 和 Q。这需要大约 10 秒才能运行超过 12k A 列和 K 列超过 2500。
Sub match_columns()
Dim I, total, fRow As Integer
Dim found As Range
total = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For I = 1 To total
answer1 = Worksheets(1).Range("A" & I).Value
Set found = Sheets(2).Columns("K:K").Find(what:=answer1) 'finds a match
If found Is Nothing Then
Worksheets(1).Range("Q" & I).Value = "NO MATCH"
Else
fRow = Sheets(2).Columns("K:K").Find(what:=answer1).Row
Worksheets(1).Range("O" & I).Value = Worksheets(2).Range("O" & fRow).Value
Worksheets(1).Range("P" & I).Value = Worksheets(2).Range("P" & fRow).Value
Worksheets(1).Range("Q" & I).Value = Worksheets(2).Range("Q" & fRow).Value
End If
Next I
End Sub
回答by TheCricket
Thank you again @Mooseman for providing the solution!
再次感谢@Mooseman 提供解决方案！
I only had to change Range A with K, at first even so I was not able to make it work as it copied only the first line. I already had some code which opened the Worksheets and copied them to a new Worksheet/added new columns ..etc., to be SavedAs for later use, and it seems that because of this your code was not able to loop properly (not sure how to explain this) in any case at the end of the open / save workbooks ..etc I have introduced a Call Sub Procedurewhich worked like a charm!
我只需要用 K 更改范围 A，即使如此我也无法使其工作，因为它只复制了第一行。我已经有一些代码可以打开工作表并将它们复制到新的工作表/添加新列..等，以供以后使用，并且似乎因此您的代码无法正确循环（不确定如何解释这一点）无论如何在打开/保存工作簿..等的末尾我已经介绍了一个调用子程序，它的工作原理非常棒！
Also, introduced two extra lines to properly format columns O and P as Date.
此外，引入了两行额外的行以将列 O 和 P 正确格式化为日期。
I am sure it could have looked better than this, but so far it works!
我相信它看起来可能比这更好，但到目前为止它有效！
And thank you to everyone who provided me with suggestions, there is still a lot to learn and I am planning to test other ways just for the sake of learning, but I needed this to work now.
感谢所有为我提供建议的人，还有很多东西需要学习，我正计划为了学习而测试其他方法，但我现在需要它来工作。
Sub Button1_Click()
With Application
.AskToUpdateLinks = False
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Code to Open / Save / introduce new columns into Sheet(1)
Call match_columns
End Sub
Sub match_columns()
Dim I, total, frow As Integer
Dim found As Range
total = Sheets(1).Range("K" & Rows.Count).End(xlUp).Row
'MsgBox (total) --> used to test if it can count/see the total number of rows
For I = 2 To total
answer1 = Worksheets(1).Range("K" & I).Value
Set found = Sheets(2).Columns("A:A").Find(what:=answer1) 'finds a match
If found Is Nothing Then
Worksheets(1).Range("Q" & I).Value = "NO MATCH"
Else
frow = Sheets(2).Columns("A:A").Find(what:=answer1).Row
Worksheets(1).Range("O" & I).Value = Worksheets(2).Range("O" & frow).Value
Worksheets(1).Range("P" & I).Value = Worksheets(2).Range("P" & frow).Value
Worksheets(1).Range("Q" & I).Value = Worksheets(2).Range("Q" & frow).Value
End If
Next I
Worksheets(1).Range("P2", "P" & total).NumberFormat = "dd.mm.yyyy"
Worksheets(1).Range("O2", "O" & total).NumberFormat = "dd.mm.yyyy"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
End With
End Sub
回答by Benjamin Goldwater
This is slow because your macro is iterating through 55,000 * 2,500 rows of data, twice. That's 275,000,000 cycles.
这很慢，因为您的宏要遍历 55,000 * 2,500 行数据两次。那是 275,000,000 个周期。
I think the solution is to scrap the macro and use VLOOKUPor IndexMatch.
我认为解决方案是废弃宏并使用VLOOKUPor IndexMatch。
You could add this formula to cell Q2 of sheet1:
您可以将此公式添加到 sheet1 的单元格 Q2 中：
=IFERROR(INDEX(Sheet2!$Q:$Q,MATCH(Sheet1!$K2,Sheet2!$A:$A,0)),"NO MATCH")
That is how I would do this. If you need it to be a macro, you can write a macro that just sets Sheet1 K2 to have this formula and drag the formula down.
这就是我要做的。如果你需要它是一个宏，你可以写一个宏，只设置 Sheet1 K2 有这个公式，然后向下拖动公式。
