Question

这是一个绝对的初学者，在任何形式的编码，这是我第一次尝试使用VBA。

我经过一个半星期的搜索和测试，并且学习了下面的代码并且我已经打了一个WALL（我甚至还没完成！）

我想要实现的目标：

将sheet1中的数据与分别为K列中的sheet2中的数据进行比较（K中有大约55.000行，A中有2500行），数据可能会重复，因为这些是产品代码，最后可以正常我希望能够看到哪些已过期。

所以..如果K = A则必须复制Sheet2中的相邻值 - 列O，P＆amp; Q并将它们粘贴在Sheet2中 - 列O，P＆amp; Q如果找不到匹配则找不到。在下面的示例中，我只尝试复制Q，如果我尝试添加O＆amp; P上。

（注意：我在这里的一个表单中找到了这个代码，并在尝试使用select / Copy / Paste等不同的其他方法后使用它，但没有一个有效）

稍后我想尝试在Sheet1中添加另一列，并根据将被复制到Sheet1的日期和P列填充Expired或很快将根据具体情况过期，但这是一个完全不同的故事我甚至还没有开始考虑如何去做。

问题是我当前的代码需要花费一个多小时，而且在我写这篇文章的时候还没有完成！我不明白我哪里出错了......

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

确保没有任何阻碍。

请帮忙！

Answer 1

这将遍历行以匹配Sheet1上的列A和sheet2上的列K.在不匹配＆＃34;不匹配＆＃34;将放在Sheet1列Q中。在匹配Sheet2列O，P和Q将被复制到Sheet1列O，P和Q. 在A列中运行超过12k，在K列中运行超过2500，这需要大约10秒。

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

Answer 2

再次感谢@Mooseman提供解决方案！

我只需要用K改变范围A，即使这样我也无法使其工作，因为它只复制了第一行。我已经有一些代码打开了工作表并将它们复制到一个新的工作表/添加了新的列..等等，以供以后保存以供以后使用，似乎因为这个你的代码无法正常循环（不确定）如何解释这个）在任何情况下，在打开/保存工作簿结束时..我已经介绍了Call Sub Procedure，它就像一个魅力！

另外，引入了两条额外的行来正确地将列O和P格式化为Date。

我相信它看起来可能比这更好，但到目前为止它的确有效！

感谢所有向我提供建议的人，还有很多需要学习的东西，我打算为了学习而尝试其他方法，但我现在需要这个。

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

Answer 3

这很慢，因为你的宏正在迭代55,000 * 2,500行数据，两次。这是275,000,000个周期。

我认为解决方案是废弃宏并使用VLOOKUP或Index Match。

您可以将此公式添加到sheet1的单元格Q2：

=IFERROR(INDEX(Sheet2!$Q:$Q,MATCH(Sheet1!$K2,Sheet2!$A:$A,0)),"NO MATCH")

我就是这样做的。如果你需要它是一个宏，你可以编写一个宏，只需将Sheet1 K2设置为具有此公式并向下拖动公式。

Excel VBA - 比较两个不同工作表中的两列然后复制/粘贴 - 速度 - 这需要一个多小时

3 个答案: