Excel VBA – 比较两个不同工作表中的两列，然后复制/粘贴 – 速度 – 需要一个多小时
这里绝对是任何forms的编程初学者，这是我第一次尝试使用VBA。
我经过了一个半星期的search和testing，并学习了下面的代码，我打了一个墙（而且我还没有完成！）
我正在努力实现的是：
比较sheet1中的数据和列K中分别find的sheet2中的数据A（K中有大约55.000行，A中是2500），数据可能会重复，因为这些是产品代码，在本I希望能够看到哪些已经过期。
所以..如果K = A，那么它必须复制Sheet2中find的相邻值 – 列O，P和Q，并将它们粘贴到Sheet2 – 列O，P和Q中，如果找不到匹配，则找不到。 在下面的例子中，我只是试图复制Q，如果我尝试添加O＆P，可能会永远耗费时间。
（注意：我已经在这里find了这个代码，并用select / Copy / Paste等方法尝试了其他的方法后使用它，但是没有任何工作）
后来我想尝试在Sheet1中添加另一个列，并根据将被复制到Sheet1的date和列P填充到Expired或Soon根据大小写而过期，但是这是一个完全不同的故事，甚至没有开始考虑如何去做。
问题是我目前的代码需要一个多小时，而我写这个时还没有完成。 我不明白我哪里错了….
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 我也用过：
With Application .AskToUpdateLinks = False .ScreenUpdating = False .DisplayAlerts = False .EnableEvents = False End With
为了确保没有任何东西挡住了路。
请帮忙！
这将遍历行以匹配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
@Mooseman再次感谢您提供解决scheme！
我只需要用K改变范围A，起初即使这样我也不能使它工作，因为它只复制第一行。 我已经有一些代码，打开工作表，并将其复制到一个新的工作表/添加新的列..等等，被保存为以后使用，似乎正因为如此，你的代码无法正常循环（不确定如何解释这个）在任何情况下，在打开/保存工作簿的结尾..等我已经介绍了一个呼叫子程序 ，像一个魅力工作！
此外，引入了两个额外的行来正确格式化O和P列date。
我相信它可能看起来比这更好，但到目前为止它的工作原理！
感谢所有给我提出build议的人，还有很多需要学习的东西，而且我正在计划为了学习而尝试其他方法，但现在我需要这个工作。
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
这很慢，因为您的macros正在遍历55,000 * 2,500行数据，两次。 这是275,000,000个周期。
我认为解决scheme是废除macros，并使用VLOOKUP或Index Match 。
您可以将此公式添加到sheet1的单元格Q2：
=IFERROR(INDEX(Sheet2!$Q:$Q,MATCH(Sheet1!$K2,Sheet2!$A:$A,0)),"NO MATCH")
这就是我将如何做到这一点。 如果你需要它是一个macros，你可以写一个macros，只是设置Sheet1 K2有这个公式，并拖动公式。