Question

在我的主工作簿中，我的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

Answer 1

到目前为止我看到的问题：

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“）。值。这也意味着您不必粘贴。

宏的一些主要性能提示建议不要“复制/粘贴”以及尽量避免“选择”和“激活”。实际上，直接操作工作表通常被视为主要罪。

对于需要移动的较大数据集，在转储到新位置之前将所有内容存储在数组中也可以节省大量时间。

希望这会有所帮助。

清理表格需要太长时间，从另一个工作簿复制，粘贴和自动填充公式

1 个答案: