用于比较和复制数据从一张纸到另一张纸需要很长时间的宏 [英] Macro to compare and copy data from one sheet to another taking a long time

问题描述

我使用这个宏将内容从一个Excel表复制到另一个，通过比较两列并找到匹配的单元格。问题是这个宏需要很长时间（近3天）才能完成。在两张表中有近400,000条记录进行比较。

I used this macro to copy contents from one Excel sheet to another, by comparing two columns and finding a matching cell. The problem is that this macro is taking a long time (close to three days) to complete. There are close to 4,00,000 records in both the sheets to compare against.

有人可以帮我做些事情吗？

Can someone please help me to make things faster?

    Option Explicit
    Sub MatchAndCopy()

       Dim sheet01 As Worksheet, sheet02 As Worksheet
       Dim count As Range, matchingCell As Long
       Dim RangeInSheet1 As Variant
       Dim RangeInSheet2 As Variant

       Application.ScreenUpdating = False
       Application.DisplayStatusBar = True

       Set sheet01 = Worksheets("Sheet1")
       Set sheet02 = Worksheets("Sheet2")
       Set RangeInSheet1 = sheet01.Columns(1)
       Set RangeInSheet2 = sheet02.Range("A2", sheet02.Range("A" & Rows.count).End(xlUp))


       For Each count In RangeInSheet2
         matchingCell = 0
         On Error Resume Next
         matchingCell = Application.Match(count, RangeInSheet1, 0)
         On Error GoTo 0
         If matchingCell <> 0 Then
           Application.StatusBar = "Please wait while data is being copied, Processing count : " & count
           sheet01.Range("F" & matchingCell).Value = count.Offset(, 1)
           sheet01.Range("G" & matchingCell).Value = count.Offset(, 2)
           sheet01.Range("H" & matchingCell).Value = count.Offset(, 3)
           sheet01.Range("I" & matchingCell).Value = count.Offset(, 4)
           sheet01.Range("J" & matchingCell).Value = count.Offset(, 5)
         End If
       Next count

       Application.StatusBar = False
       Application.ScreenUpdating = True

    End Sub

推荐答案

应该更快：

Sub MatchAndCopy()

    Dim sheet01 As Worksheet, sheet02 As Worksheet
    Dim c As Range, matchingCell As Long
    Dim RangeInSheet1 As Range
    Dim RangeInSheet2 As Range
    Dim dict As Object, tmp
    Set dict = CreateObject("scripting.dictionary")

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True

    Set sheet01 = Worksheets("Sheet1")
    Set sheet02 = Worksheets("Sheet2")

    Set RangeInSheet1 = sheet01.Range(sheet01.Range("A2"), _
              sheet01.Cells(Rows.count, 1).End(xlUp))
    Set RangeInSheet2 = sheet02.Range(sheet02.Range("A2"), _
              sheet02.Cells(Rows.count, 1).End(xlUp))

    'populate dictionary...
    For Each c In RangeInSheet1.Cells
        tmp = c.Value
        If Not dict.exists(tmp) Then
            dict.Add tmp, c.Row
        End If
    Next c

    For Each c In RangeInSheet2.Cells
      tmp = c.Value
      If dict.exists(tmp) Then
        Application.StatusBar = "Please wait while data is being copied," & _
                                " Processing count : " & c.Row
        sheet01.Cells(dict(tmp), "F").Resize(1, 5).Value = _
                c.Offset(0, 1).Resize(1, 5).Value
      End If
    Next c

    Application.StatusBar = False
    Application.ScreenUpdating = True

End Sub

这篇关于用于比较和复制数据从一张纸到另一张纸需要很长时间的宏的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！