余分な時間をかけて別のブックをコピーし、貼り付け、オートフィルの式をコピーします

Question

私のマスターブックには、4枚1枚とシート2と4枚のそれぞれに1枚のテーブルがあります。IFとVLOOKUP表の右側にある機能です。

私は次のことをしようとしています：
別のブックのシート1のテーブルからコピーしたい範囲をコピーします（繰り返し
マスターワークブックのシート1のテーブルに貼り付けます（他のシートについては繰り返します）。
シートの2番目と4番目のリマーナリングカラムの式を自動入力します。

コードは仕事ですが、この作業を実行するには約2時間かかります！
シート2のClearcontentでさえ250行で8分かかりますが、これはばかばかしい長い時間です！
シート1には1000行、シート2には250、シート3には1000、シート4には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 

Answer 1

の問題は、私がこれまで見：あなたはyoureのは文字通りどこ内容をクリアするためにそれを伝えるため、アクティブにする必要はありません

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 

コピーする必要はありません、あなたは文字通り「範囲（ 『A1』）のようなものを言うことができます。値=範囲（ 『C2』）。値。これはまた、あなたが貼り付ける必要もないということを拡張することを意味します。

マクロの主なパフォーマンスヒントのなかには、「コピー/貼り付け」や「選択」や「アクティブ化」を避けようとするものがあります。実際、ワークシートを直接操作することは、

大規模なデータセットを移動する必要があるため、新しい場所にダンプする前にすべてを配列に格納することで時間を大幅に節約できます。

これが役に立ちます。