慢跑宏-有解無憂

我創建了一個宏（使用大量在線幫助）從一張紙中獲取資料，創建另一張紙，格式化資料并設定列印機。一切正常，但宏似乎需要很長時間才能運行。有人可以查看我的代碼，看看我是否做了一些我不應該做的事情嗎？

謝謝

Sub Preactor_Sort()
    Application.ScreenUpdating = False
'**Copy "Full List" Data into New Sheet**
    Sheets("FULL LIST").Select
    Range("A8:R8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add(Before:=Sheets("MASTER")).Name = "Sorted Full"
    Range("A1").Select
    ActiveSheet.Paste
    ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
    Cells.FormatConditions.Delete
    Cells.Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 9
        .Bold = False
        .Color = vbBlack
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .Interior.ColorIndex = 0
        .RowHeight = 23
    End With
    Cells.EntireColumn.AutoFit
'***************************************************
'**Deleting Unwanted Columns**
    Columns("E:E").Select
    Selection.Cut
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:C").Select
    Range("A1").Activate
    Selection.Delete Shift:=xlToLeft
'***************************************************
'**Rearranging Columns**
    Columns("G:H").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("K:L").Select
    Selection.Cut
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight
'****************************************************
'**Sorting Day/Date**
    Columns("C:C").Select
    Selection.NumberFormat = "dd/mm/yy hh:mm"
    Columns("C:C").EntireColumn.AutoFit
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Select
    Selection.NumberFormat = "General"
    '**Find Last Row**
    LR = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
    '**Insert Formula**
    Range("C2").Formula = "=TEXT(D2,""ddd"")"
    '**Drag Formula down to last row**
    Range("C2").AutoFill Range("C2:C" & LR)
    Columns("C:C").EntireColumn.AutoFit
'*****************************************************
'**Sorting**
    With ActiveSheet.Sort
        .SortFields.Add2 Key:=Range("C1"), Order:=xlAscending, CustomOrder:="Mon,Tue,Wed,Thu,Fri,Sat,Sun", DataOption:=xlSortNormal
        .SortFields.Add2 Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Make,Discharge,Packing,Wrapping", DataOption:=xlSortNormal
        .SetRange Range("A:P")
        .Header = xlYes
        .Apply
    End With
'******************************************************
'**Formatting**
    Range("C:C,E:E").Select
    With Selection
        .Font.Bold = True
    End With
    Columns("B:B").Select
    Selection.ColumnWidth = 10
    Columns("F:G").Select
    Selection.ColumnWidth = 25
    Columns("A:A").Select
    Selection.ColumnWidth = 8
    Columns("I:J").Select
    Selection.ColumnWidth = 5
    Columns("L:N").Select
    Selection.ColumnWidth = 15
    Columns("O:O").Select
    Selection.ColumnWidth = 80
    Columns("H:H").Select
    Selection.ColumnWidth = 40
    Columns("K:K").Select
    Selection.ColumnWidth = 6
'**Conditional Formatting**
'** Alternating Rows
    Dim lastRow As Long
    lastRow = Range("A1:P1").End(xlDown).Row
    For Each cell In Range("A1:P" & lastRow)
        If cell.Row Mod 2 = 1 Then
            cell.Interior.ColorIndex = 34 'Light Blue
        End If
    Next cell
'**Highlighting Operations
    Dim cell1 As Range
    For Each cell1 In Range("B:B")
        If cell1.Value = "Make" Then
        cell1.Interior.ColorIndex = 35 'Light Green
        ElseIf cell1.Value = "Discharge" Then
        cell1.Interior.ColorIndex = 36 'Light Yellow
        ElseIf cell1.Value = "Packing" Then
        cell1.Interior.ColorIndex = 19 'Light Cream
        ElseIf cell1.Value = "Wrapping" Then
        cell1.Interior.ColorIndex = 6 'Yellow
        ElseIf cell1.Value = "Boxing" Then
        cell1.Interior.ColorIndex = 44 'Light Orange
        ElseIf cell1.Value = "Oil Phase" Then
        cell1.Interior.ColorIndex = 38 'Pink
        End If
    Next
'**Highlighting Day
    Dim cell2 As Range
    For Each cell2 In Range("C:C")
        If cell2.Value = "Mon" Then
        cell2.Interior.ColorIndex = 7 'Pink
        ElseIf cell2.Value = "Tue" Then
        cell2.Interior.ColorIndex = 4 'Green
        ElseIf cell2.Value = "Wed" Then
        cell2.Interior.ColorIndex = 6 'Yellow
        ElseIf cell2.Value = "Thu" Then
        cell2.Interior.ColorIndex = 45 'Orange
        ElseIf cell2.Value = "Fri" Then
        cell2.Interior.ColorIndex = 33 'Blue
        End If
    Next
'** Top Bar Colour
    Range("A1:P1").Select
    With Selection
        .Interior.ColorIndex = 15
        .Font.Bold = True
    End With
'*********************************************************
'** Printer Setup
    Application.PrintCommunication = True
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.12)
        .RightMargin = Application.InchesToPoints(0.12)
        .TopMargin = Application.InchesToPoints(0.16)
        .BottomMargin = Application.InchesToPoints(0.16)
        .HeaderMargin = Application.InchesToPoints(0.12)
        .FooterMargin = Application.InchesToPoints(0.12)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA3
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
    End With
   ' Application.PrintCommunication = False
End Sub

uj5u.com熱心網友回復：

嘗試添加這個，它通過關閉螢屏更新、事件、影片等來加速，這應該會加快一點！

在代碼的開頭添加這個子

Call TurnOffCode

在你的代碼末尾添加這個子

Call TurnOnCode

這就是他們應該看起來的樣子

Sub TurnOffCode() 'Used to turn off settings to make workbook run faster
Application.Calculation = xlCalculationManual 'Set calculations to manual
Application.ScreenUpdating = False 'Turns off screen updating
Application.EnableEvents = False 'Turns off events
Application.EnableAnimations = False 'Turns off animations
Application.DisplayStatusBar = False 'Turns off display status bar
Application.PrintCommunication = False 'Turns off print communications
End Sub

Sub TurnOnCode() 'Used to turn settings back on to normal
Application.Calculation = xlCalculationAutomatic 'Set calculations to automatic
Application.ScreenUpdating = True 'Turns on screen updating
Application.EnableEvents = True 'Turns on events
Application.EnableAnimations = True 'Turns on animations
Application.DisplayStatusBar = True 'Turns on display status bar
Application.PrintCommunication = True 'Turns on print communications
End Sub

但是，您也應該避免使用選擇，查看顯示該資訊的頁面的評論部分

uj5u.com熱心網友回復：

謝謝你幫我看這個。

我嘗試了 EuanM28 提供的解決方案，這確實略微提高了速度 - 從 38 秒到大約 34 秒。

我對我的代碼進行了一些調整

Dim cell1 As Range
For Each cell1 In Range("B:B")

至

Dim cell1 As Range
For Each cell1 In Range("B2:B" & LR) '*LR = last row variable defined earlier in the code

和

Dim cell2 As Range
For Each cell2 In Range("C:C")

至

Dim cell2 As Range
For Each cell2 In Range("C2:C" & LR)

我猜這產生了巨大的差異（34 秒到 6 秒），因為它不再回圈遍歷作業表上的所有行而只是填充的行。

我將不得不考慮按照建議洗掉 .Selects （沒有意識到它會導致這么多問題！）

謝謝

uj5u.com熱心網友回復：

你的代碼中有很多select陳述句，只是為了隨后做一些selection你可以避免的事情。

像下面這樣的部分

    Application.ScreenUpdating = False
    '**Copy "Full List" Data into New Sheet**
    Sheets("FULL LIST").Select
    Range("A8:R8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add(Before:=Sheets("MASTER")).Name = "Sorted Full"
    Range("A1").Select
    ActiveSheet.Paste
    ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
    Cells.FormatConditions.Delete
    Cells.Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 9
        .Bold = False
        .Color = vbBlack
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .Interior.ColorIndex = 0
        .RowHeight = 23
    End With
    Cells.EntireColumn.AutoFit

可以改寫為：

    Dim slc As Range
    Dim rng As Range

    'Application.ScreenUpdating = False <= be careful with setting update to false as it will not restore if your program encounters an error!
    '**Copy "Full List" Data into New Sheet**

    Set rng = Sheets(1).Range("A8:R8")
    Set slc = Range(rng, rng.End(xlDown))
    slc.Copy
    
    Sheets.Add(Before:=Sheets(1)).Name = "Sorted Full"
    Sheets("Sorted Full").Paste
    ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
    Cells.FormatConditions.Delete
    With Cells.Font
        .Name = "Calibri"
        .Size = 9
        .Bold = False
        .Color = vbBlack
    End With
    With Cells
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .Interior.ColorIndex = 0
        .RowHeight = 23
    End With
    Cells.EntireColumn.AutoFit

這將防止 Excel 發出select導致執行緩慢和螢屏閃爍的陳述句。

如果您在整個代碼中應用它，您將獲得更清晰的執行，而無需關閉螢屏更新。

所以，如果你稍微清理一下你的代碼，它可能如下所示：請注意，即使這樣也有很大的改進空間，但至少它擺脫了大多數select陳述句。

這仍然可以與@EuanM28 提出的解決方案結合使用。但是，切換計算和螢屏更新有一些缺點，如果您的宏遇到錯誤，可能需要適當的 ErrorHandling。

因此，將它們組合起來如下所示：

    Sub Preactor_Sort()
    On Error GoTo ErrorHandler '<= called in case of an Error
    Call ToggleCode(False)
    
    Dim slc As Range
    Dim rng As Range

    'Application.ScreenUpdating = True
    '**Copy "Full List" Data into New Sheet**
    
    Set rng = Sheets(1).Range("A8:R8")
    Set slc = Range(rng, rng.End(xlDown))
    slc.Copy
    
    Sheets.Add(Before:=Sheets(1)).Name = "Sorted Full"
    Sheets("Sorted Full").Paste
    ActiveWindow.Zoom = 60
    '**************************************************
    
    '**Formatting and removing previous conditional formatting**
    With Cells
        .FormatConditions.Delete
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .Interior.ColorIndex = 0
        .RowHeight = 23
        With .Font
            .Name = "Calibri"
            .Size = 9
            .Bold = False
            .Color = vbBlack
        End With
        .EntireColumn.AutoFit
    End With
    '***************************************************
    
    '**Deleting Unwanted Columns**
    columns("E:E").Cut
    columns("C:C").Insert Shift:=xlToRight
    columns("A:C").Delete Shift:=xlToLeft
    '***************************************************
    
    '**Rearranging Columns**
    columns("G:H").Cut
    columns("B:B").Insert Shift:=xlToRight
    columns("K:L").Cut
    columns("E:E").Insert Shift:=xlToRight
    '****************************************************
    
    '**Sorting Day/Date**
    columns("C:C").NumberFormat = "dd/mm/yy hh:mm"
    columns("C:C").EntireColumn.AutoFit
    columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    columns("C:C").NumberFormat = "General"
    '**Find Last Row**
    LR = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).row
    '**Insert Formula**
    Range("C2").Formula = "=TEXT(D2,""ddd"")"
    '**Drag Formula down to last row**
    Range("C2").AutoFill Range("C2:C" & LR)
    columns("C:C").EntireColumn.AutoFit
    '*****************************************************
    
    '**Sorting**
    With ActiveSheet.Sort
        .SortFields.Add2 Key:=Range("C1"), Order:=xlAscending, CustomOrder:="Mon,Tue,Wed,Thu,Fri,Sat,Sun", DataOption:=xlSortNormal
        .SortFields.Add2 Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Make,Discharge,Packing,Wrapping", DataOption:=xlSortNormal
        .SetRange Range("A:P")
        .Header = xlYes
        .Apply
    End With
    '******************************************************
    
    '**Formatting**
    Range("C:C,E:E").Font.Bold = True
    columns("B:B").ColumnWidth = 10
    columns("F:G").ColumnWidth = 25
    columns("A:A").ColumnWidth = 8
    columns("I:J").ColumnWidth = 5
    columns("L:N").ColumnWidth = 15
    columns("O:O").ColumnWidth = 80
    columns("H:H").ColumnWidth = 40
    columns("K:K").ColumnWidth = 6
    '**Conditional Formatting**
    '** Alternating Rows
    Dim lastRow As Long
    lastRow = Range("A1:P1").End(xlDown).row
    For Each cell In Range("A1:P" & lastRow)
        If cell.row Mod 2 = 1 Then
            cell.Interior.ColorIndex = 34 'Light Blue
        End If
    Next cell
        '**Highlighting Operations
    Dim cell1 As Range
    For Each cell1 In Range("B:B")
        If cell1.value = "Make" Then
        cell1.Interior.ColorIndex = 35 'Light Green
        ElseIf cell1.value = "Discharge" Then
        cell1.Interior.ColorIndex = 36 'Light Yellow
        ElseIf cell1.value = "Packing" Then
        cell1.Interior.ColorIndex = 19 'Light Cream
        ElseIf cell1.value = "Wrapping" Then
        cell1.Interior.ColorIndex = 6 'Yellow
        ElseIf cell1.value = "Boxing" Then
        cell1.Interior.ColorIndex = 44 'Light Orange
        ElseIf cell1.value = "Oil Phase" Then
        cell1.Interior.ColorIndex = 38 'Pink
        End If
    Next
    '**Highlighting Day
    Dim cell2 As Range
    For Each cell2 In Range("C:C")
        If cell2.value = "Mon" Then
        cell2.Interior.ColorIndex = 7 'Pink
        ElseIf cell2.value = "Tue" Then
        cell2.Interior.ColorIndex = 4 'Green
        ElseIf cell2.value = "Wed" Then
        cell2.Interior.ColorIndex = 6 'Yellow
        ElseIf cell2.value = "Thu" Then
        cell2.Interior.ColorIndex = 45 'Orange
        ElseIf cell2.value = "Fri" Then
        cell2.Interior.ColorIndex = 33 'Blue
        End If
    Next
    '** Top Bar Colour
    'Range("A1:P1").Select
    With Range("A1:P1")
        .Interior.ColorIndex = 15
        .Font.Bold = True
    End With
    '*********************************************************
    
    '** Printer Setup
    'Application.PrintCommunication = True
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.12)
        .RightMargin = Application.InchesToPoints(0.12)
        .TopMargin = Application.InchesToPoints(0.16)
        .BottomMargin = Application.InchesToPoints(0.16)
        .HeaderMargin = Application.InchesToPoints(0.12)
        .FooterMargin = Application.InchesToPoints(0.12)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA3
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
    End With
   ' Application.PrintCommunication = False
   Call ToggleCode(True)
Exit Sub

ErrorHandler:
    Call ToggleCode(True) '<= this ensures your application get's reset in case of an Error

End Sub

Sub ToggleCode(Optional switch As Boolean = True) 'Used to turn on/off settings to make workbook run faster
    If (switch) Then
        Application.Calculation = xlCalculationAutomatic  'Set calculations to automatic
    Else
        Application.Calculation = xlCalculationManual  'Set calculations to manual
    End If
    
    Application.ScreenUpdating = switch 'Turns on/off screen updating
    Application.EnableEvents = switch 'Turns on/off events
    Application.EnableAnimations = switch 'Turns on/off animations
    Application.DisplayStatusBar = switch 'Turns on/off display status bar
    Application.PrintCommunication = switch 'Turns on/off print communications
End Sub

轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/526512.html

標籤：擅长vba

上一篇：使用VBA將一個單元格的值復制到另一個匹配的單元格

下一篇：VBA調整選定范圍而不是整個作業表的評論大小