Question

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

它使用 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

Answer 1

使用 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

Worksheet.Paste 运行非常缓慢

1 个答案: