时间戳

首页 > 解决方案 > Worksheet.Paste 运行速度极慢

excel - Worksheet.Paste 运行速度极慢

问题描述

我下面的代码使用文件名中的国家/地区名称来标识国家/地区表中该国家/地区的行，然后复制偏移值。

它使用 Worksheet.Paste，但运行速度非常慢，并且在 5 到 6 个文件（超过 50 个文件中）后会中断，因此我将不胜感激有关调整此问题的提示。

使用 Range.Copy 和 Destination 的相同代码运行良好，但 Destination 不能用于粘贴链接。

Sub Header_Paste_Link()

Dim Path As String, Filename As String, Country As String, _
Name As String, Leftname As String
Dim wb As Workbook
Dim i As Integer
Dim rng As Range

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Path = "C:\Users\xyz\Documents\xyz\xyz\"
Filename = Dir(Path & "*.xlsx")

On Error GoTo PasteFail

Do While Len(Filename) > 0

    Set wb = Workbooks.Open(Path & Filename)
    
CopyX:

    Name = wb.Name
    Leftname = Left(Name, InStr(Name, "_") - 1)
    With wb.Sheets("Countries").Range("A:A")
        Set rng = .Find(What:=Leftname, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
            If Not rng Is Nothing Then
            
            rng.Offset(, 2).Copy _
            Worksheets("Header").Range("B1").Activate
            ActiveSheet.Paste Link:=True
            Worksheets("Header").Range("G1").Activate
            ActiveSheet.Paste Link:=True
            
            rng.Offset(, 3).Copy
            Worksheets("Header").Range("D1").Select
            ActiveSheet.Paste Link:=True

            rng.Offset(, 5).Copy
            Worksheets("Header").Range("I1").Select
            ActiveSheet.Paste Link:=True        

            End If
    End With

    i = i + 1
    ActiveWorkbook.Close savechanges:=True
    Filename = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True

PasteFail:
    If Err.Number = 4605 Then
        DoEvents
        Resume CopyX
    ElseIf Err.Number = 1004 Then
        Resume CopyX
    Else
        GoTo ErrMsg
    End If

ErrMsg:
    MsgBox Err.Number & vbCr & Err.Description
    
End Sub

标签： excelvbacopy-pasteworksheet-function

解决方案

使用Activate和Select导致减速。您可以通过设置替换Copy和（不格式化；如果相关）。也更快。试试这段代码（部分测试）：.Paste Link:=True.FormulaApplication.Match.Find

With wb.Sheets("Countries")
    m = Application.Match(Leftname, .Range("A:A"), 0)
    If IsNumeric(m) Then
        Set Rng = .Cells(m, "A")
        With Worksheets("Header")
            .Range("B1").Formula = "=" & Rng.Offset(, 2).Address(External:=True)
            .Range("G1").Formula = "=" & Rng.Offset(, 2).Address(External:=True)
            .Range("D1").Formula = "=" & Rng.Offset(, 3).Address(External:=True)
            .Range("I1").Formula = "=" & Rng.Offset(, 5).Address(External:=True)
        End With
    End If
End With

推荐阅读