Question

我使用此宏将内容从一个Excel工作表复制到另一个工作表，方法是比较两列并找到匹配的单元格。问题是这个宏需要很长时间（接近三天）才能完成。两张纸都有近4,00,000条记录可供比较。

有人可以帮助我加快速度吗？

    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

Answer 1

应该更快：

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

Answer 2

使用

立即获取整张纸

var values = sheet.getDataRange().getValues();

并在本地比较值

修改-1
Google Apps脚本文档https://developers.google.com/apps-script/reference/spreadsheet/spreadsheet为getDataRange（）

提供了以下示例
Returns a Range corresponding to the dimensions in which data is present. This is functionally equivalent to creating a Range bounded by A1 and (Range.getLastColumn(), Range.getLastRow()). var ss = SpreadsheetApp.getActiveSpreadsheet(); var sheet = ss.getSheets()[0]; // This represents ALL the data var range = sheet.getDataRange(); var values = range.getValues(); // This logs the spreadsheet in CSV format with a trailing comma for (var i = 0; i < values.length; i++) { var row = ""; for (var j = 0; j < values[i].length; j++) { if (values[i][j]) { row = row + values[i][j]; } row = row + ","; } Logger.log(row); }

不应使用大量范围，而应在一次通话中获取数据并在本地处理

宏用于比较和复制数据从一张纸到另一张需要很长时间

2 个答案: