在我的主工作簿中，我的4张表中每张都有1张表，而在sheet2和sheet4中，我在表的右边有几列IF和VLOOKUP函数。
我正在尝试执行以下操作：
清除4个表中的内容，同时仅保留一行公式（在表2和表4中），
从sheet1中的表复制我想要的范围另一个工作簿（重复其他工作表），
粘贴到主工作簿的sheet1表中（重复其他工作表），
自动填充重新列的公式（仅在表2和表4中） 。
虽然代码完成了它的工作，但是执行这项任务需要将近2个小时！即使是Sheet2的Clearcontent需要8分钟才能完成250行，这看起来很荒谬！
Sheet1有1000行，sheet2有250，sheet3有1000，sheet4有26k行。
代码看起来太大了。我可以做些什么来优化和加速代码？
任何可行的工作或这是正常的吗？
我尝试过Application.Calculation = xlCalculationManual但没有改进。
Sub LoopThroughDirectory()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim MyFile As String
Dim erow1
Dim erow2
Dim erow3
Dim erow4
Dim Filepath As String
Dim wkb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim sht4 As Worksheet
Dim ero2 As Long
Dim ero4 As Long
Dim lastero1 As Long
Dim lastero2 As Long
Dim lastero3 As Long
Dim lastero4 As Long
Folha1.Activate
Folha1.Range(Cells(3, 1), Cells(99999, 173)).ClearContents
Folha1.Range(Cells(2, 1), Cells(99999, 173)).ClearContents
Folha2.Activate
Folha2.Range(Cells(3, 1), Cells(99999, 150)).ClearContents
Folha2.Range(Cells(2, 1), Cells(99999, 137)).ClearContents
Folha3.Activate
Folha3.Range(Cells(3, 1), Cells(99999, 197)).ClearContents
Folha3.Range(Cells(2, 1), Cells(99999, 197)).ClearContents
Folha4.Activate
Folha4.Range(Cells(3, 1), Cells(99999, 152)).ClearContents
Folha4.Range(Cells(2, 1), Cells(99999, 108)).ClearContents
Filepath = "C:\Users\carlos\Downloads\Projectos\Teste\"
MyFile = Dir(Filepath)
Do While MyFile = "Dados Projectos New"
If MyFile = "Dados Projectos_Master.xlsm" Then
Exit Sub
End If
Set wkb = Workbooks.Open(Filepath & MyFile)
Set sht1 = wkb.Sheets("Encomendas")
Set sht2 = wkb.Sheets("Projectos")
Set sht3 = wkb.Sheets("Casos")
Set sht4 = wkb.Sheets("Actividades Serviço")
wkb.Activate
sht1.Activate
With Sheets("Encomendas") 'Last row of the first sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero1 = .Range("A:fq").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:fq" & lastero1).Copy
Folha1.Activate
'last row of the first sheet of master workbook I want to paste
erow1 = Folha1.Cells.Find("*", After:=Range(Cells(Rows.Count, 173), Cells(Rows.Count, 173)), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Encomendas").Range(Cells(erow1 + 1, 1), Cells(erow1 + 1, 173))
wkb.Activate
sht2.Activate
With Sheets("Projectos") 'Last row of the second sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero2 = .Range("A:EG").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:Eg" & lastero2).Copy
Folha2.Activate
With Sheets("Projectos") 'Last row of the second sheet of master workbook I want to paste
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
erow2 = .Range("A:EG").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Projectos").Range(Cells(erow2 + 1, 1), Cells(erow2 + 1, 137))
With Sheets("Projectos") 'Last row of the second sheet of master workbook I want to autofill
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ero2 = .Range("A:EG").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("EH2:ET2").AutoFill Destination:=Range("EH2:ET" & ero2)
wkb.Activate
sht3.Activate
With Sheets("Casos") 'Last row of the third sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero3 = .Range("A:go").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:go" & lastero3).Copy
'Last row of the third sheet of master workbook I want to paste
erow3 = Folha3.Cells.Find("*", After:=Range(Cells(Rows.Count, 197), Cells(Rows.Count, 197)), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Folha3.Activate
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Casos").Range(Cells(erow3 + 1, 1), Cells(erow3 + 1, 197))
wkb.Activate
sht4.Activate
With Sheets("Actividades Serviço") 'Last row of the fourth sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero4 = .Range("A:dd").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:dd" & lastero4).Copy
ActiveWorkbook.Close
Folha4.Activate
With Sheets("Actividades serviço") 'Last row of the fourth sheet of master workbook I want to paste
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
erow4 = .Range("A:DD").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Actividades serviço").Range(Cells(erow4 + 1, 1), Cells(erow4 + 1, 108))
With Sheets("Actividades serviço") 'Last row of the fourth sheet of master workbook I want to autofill
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ero4 = .Range("A:DD").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("de2:EV2").AutoFill Destination:=Range("de2:Ev" & ero4)
MyFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
答案 0 :(得分：0)
到目前为止我看到的问题：
Folha1.Activate
Folha1.Range(Cells(3, 1), Cells(99999, 173)).ClearContents
Folha1.Range(Cells(2, 1), Cells(99999, 173)).ClearContents
您不需要激活，因为您确实告诉它清除内容的位置。
Range("a2:fq" & lastero1).Copy
无需复制，你可以字面上说“Range（”a1“）。值=范围（”C2“）。值。这也意味着您不必粘贴。
宏的一些主要性能提示建议不要“复制/粘贴”以及尽量避免“选择”和“激活”。实际上，直接操作工作表通常被视为主要罪。
对于需要移动的较大数据集，在转储到新位置之前将所有内容存储在数组中也可以节省大量时间。
希望这会有所帮助。