如何優化用於格式化的 VBA 代碼？

Question

我有以下代碼可以幫助我進行一些格式化。 但我想通過減少時間來提高代碼的效率。 以下是宏將執行的格式化步驟。

• 1. 將“Q”和“S”列”轉換為數字格式。
  2. 通過在其旁邊插入列將“I”列復制到新列。
  3. 剪切列“AD”並粘貼到列“O”。
  4. 刪除列（“A：A，AD：AG”）
  5. 將“#”替換為空值，將“OUT”替換為“AC”列中的 P 輸入值。
  6. 將“Q”和“S”列號四舍五入為 2 位小數。
  7. 通過乘以 -1(*-1) 更改列 Q 中值的符號
  8. 用“0”過濾“Q”列，用“0”過濾“S”列。 然后刪除那些帶有“Q”和“S”為零的行。
  9. 在 Q 列上過濾 0，僅清除“Q”和“R”列的可見單元格。
  10. 在“S”列上過濾 0，僅清除“S”和“T”列的可見單元格。
  11. 復制標題 (ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy) 並粘貼到格式化文件的 A1。
  12. 刪除除使用范圍之外沒有數據的所有列和行。

目前宏工作正常，但需要一些時間。因為我是 VBA 新手，不確定如何優化代碼。 因此，我在這里尋求專家的幫助。 提前致謝。

下面是代碼

Sub Ananplan_to_BPM()
Dim LastRow As Long
Dim Lastcol As Long
Dim P As String
 'Display a Dialog Box that allows to select a single file.
'The path for the file picked will be stored in fullpath variable
  With Application.FileDialog(msoFileDialogFilePicker)
        'Makes sure the user can select only one file
        .AllowMultiSelect = True
        'Filter to just the following types of files to narrow down selection options
        '.Filters.Add "All Files", "*.xlsx; *.xlsm; *.xls; *.xlsb; *.csv"
        'Show the dialog box
        .Show
        'Store in fullpath variable
        fullpath = .SelectedItems.Item(1)
    End With
    'It's a good idea to still check if the file type selected is accurate.
    'Quit the procedure if the user didn't select the type of file we need.
    If InStr(fullpath, ".xls") = 0 Then
    If InStr(fullpath, ".csv") = 0 Then
        Exit Sub
    End If
    End If
 'Open the file selected by the user
    Workbooks.Open fullpath
    P = InputBox("Please Enter the Version")
    Application.ScreenUpdating = False
With ActiveWorkbook
    Columns(17).NumberFormat = "0"
    Columns(19).NumberFormat = "0"
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
    Columns("I").Copy
    Columns("I").Insert Shift:=xlToRight
    'Range("AE2").Value = P
    'Range("AE2", "AE" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
    Columns("AE").Copy
    Columns("P").PasteSpecial xlPasteValues
    ActiveSheet.Range("A:A,AE:AG").EntireColumn.Delete
    Columns("AC").Replace What:="#", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Columns("AC").Replace What:="OUT", Replacement:=P, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Range("AD2").Formula = "=Round(Q2,2)"
    Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
    Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
    Range("Q2").PasteSpecial xlPasteValues
    Range("AD2").Formula = "=Round(S2,2)"
    Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
    Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
    Range("S2").PasteSpecial xlPasteValues
    Range("AD2").Formula = "=(Q2*-1)"
    Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
    Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
    Range("Q2").PasteSpecial xlPasteValues
    Columns("AD:AD").EntireColumn.Delete
With ActiveSheet.Range("A:AC")
    .AutoFilter Field:=17, Criteria1:="0"
    .AutoFilter Field:=19, Criteria1:="0"
    .Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilter
    .AutoFilter Field:=17, Criteria1:="0"
    .Range("Q2:R" & LastRow).SpecialCells(xlCellTypeVisible).Clear
    .AutoFilter
    .AutoFilter Field:=19, Criteria1:="0"
    .Range("S2:T" & LastRow).SpecialCells(xlCellTypeVisible).Clear
    .AutoFilter
    '.Range("C2").AutoFill .Range("C2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
    End With
End With
ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Rows("1").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
'ActiveWorkbook.Save
'ActiveWorkbook.Close
MsgBox "Done With Farmatting"
End Sub

Answer 1

這不是審查代碼的網站。 在StackOverflow系列中還有另一個，特別是為此目的。 盡管如此，我還是查看了您的代碼，並沒有發現任何我可能會特別指出使其變慢的內容。 應該有一些方法可以更快地完成工作，但它們需要了解您的意圖。 看來你有一個很大的工作表。 所以喝咖啡可能需要一點時間，但還不夠。 因此，我的評論集中在代碼固有的不精確性上，這使得它容易崩潰，並且如果在錯誤的工作表上丟失，則容易造成無法估量的損害。 我已經添加了評論。

Sub Ananplan_to_BPM()

    Dim LastRow As Long
    Dim LastCol As Long
    Dim P As String

    ' Display a Dialog Box that allows to select a single file.
    ' The path for the file picked will be stored in fullpath variable
    With Application.FileDialog(msoFileDialogFilePicker)
        ' Makes sure the user can select only one file - quite the opposite
        .AllowMultiSelect = True
        'Filter to just the following types of files to narrow down selection options
        '.Filters.Add "All Files", "*.xlsx; *.xlsm; *.xls; *.xlsb; *.csv"
        'Show the dialog box
        .Show
        'Store in fullpath variable
        fullpath = .SelectedItems.Item(1)
    End With

    ' It's a good idea to still check if the file type selected is accurate.
    If InStr(fullpath, ".xls") = 0 Or InStr(fullpath, ".csv") = 0 Then
        ' Quit the procedure if the user didn't select the type of file we need.
        Exit Sub
    End If

    'Open the file selected by the user
    Workbooks.Open fullpath
    P = InputBox("Please Enter the Version")
    Application.ScreenUpdating = False

    With ActiveWorkbook
        ' There isn't a single reference to the ActiveWorkbook
        ' in the entire 'With' bracket.
        ' Create a link to the 'With' object by a leading period.
        ' Example:-
'        With .Worksheets(1)                 ' linked to ActiveWorkbook
'            ' below, both cells and Rows.Count of Worksheets(1)
'            LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
'        End With

        ' which sheet are you working on here?
        LastRow = Cells(Rows.Count, 2).End(xlUp).Row
        LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
        Columns(17).NumberFormat = "0"
        Columns(19).NumberFormat = "0"
        Columns("I").Copy
        Columns("I").Insert Shift:=xlToRight
        'Range("AE2").Value = P
        'Range("AE2", "AE" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
        Columns("AE").Copy
        Columns("P").PasteSpecial xlPasteValues

        ' You didn't activate any sheet
        ActiveSheet.Range("A:A,AE:AG").EntireColumn.Delete
        ' everything you do above or below this line
        '' is done to the ActiveSheet


        Columns("AC").Replace What:="#", Replacement:="", LookAt:=xlPart, _
                              SearchOrder:=xlByRows, MatchCase:=False, _
                              SearchFormat:=False, ReplaceFormat:=False
        Columns("AC").Replace What:="OUT", Replacement:=P, LookAt:=xlPart, _
                              SearchOrder:=xlByRows, MatchCase:=False, _
                              SearchFormat:=False, ReplaceFormat:=False

        ' This should probably be done using a cell format.
        ' If you need rounded values in later calculations do
        ' the rounding in later calculations, not in the original data.
        Range("AD2").Formula = "=Round(Q2,2)"
        Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
        Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
        Range("Q2").PasteSpecial xlPasteValues

        Range("AD2").Formula = "=Round(S2,2)"
        Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
        Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
        Range("S2").PasteSpecial xlPasteValues

        Range("AD2").Formula = "=(Q2*-1)"
        Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
        Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
        Range("Q2").PasteSpecial xlPasteValues

        Columns("AD:AD").EntireColumn.Delete
    End With

    With ActiveSheet.Range("A:AC")
        ' This method will throw an error if there are no visible cells
        ' why not suppress the display of zero with a CellFormat?
        .AutoFilter Field:=17, Criteria1:="0"
        .AutoFilter Field:=19, Criteria1:="0"
        .Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .AutoFilter
        .AutoFilter Field:=17, Criteria1:="0"
        .Range("Q2:R" & LastRow).SpecialCells(xlCellTypeVisible).Clear
        .AutoFilter
        .AutoFilter Field:=19, Criteria1:="0"
        .Range("S2:T" & LastRow).SpecialCells(xlCellTypeVisible).Clear
        .AutoFilter
        '.Range("C2").AutoFill .Range("C2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
    End With

    ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy
    ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues

    ' you are still working on the undefined ActiveSheet
    Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Rows("1").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    'ActiveWorkbook.Save
    'ActiveWorkbook.Close
    MsgBox "Done With Formatting"
End Sub