Worksheet.Paste 运行非常缓慢

如何解决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

解决方法

使用 Activate 和 Select 会导致速度变慢。您可以通过设置 Copy（不带格式；如果相关）来替换 .Paste Link:=True 和 .Formula。 Application.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