Worksheet.Paste 运行 极慢
Worksheet.Paste running extremely slowly
我下面的代码使用文件名中的国家/地区名称来标识该国家/地区在 sheet 中的行,然后复制偏移值。
它使用 Worksheet.Paste,但运行速度极慢并且在五六个文件(超过 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
会导致速度变慢。您可以通过设置 .Formula
来替换 Copy
和 .Paste Link:=True
(无格式;如果相关)。 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
我下面的代码使用文件名中的国家/地区名称来标识该国家/地区在 sheet 中的行,然后复制偏移值。
它使用 Worksheet.Paste,但运行速度极慢并且在五六个文件(超过 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
会导致速度变慢。您可以通过设置 .Formula
来替换 Copy
和 .Paste Link:=True
(无格式;如果相关)。 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