如何加速下面的excel vba代码？

我没有做过很多VBA，而且我对这一切都比较陌生。 以下VBA当前运行时间太长，需要5分钟

有人能提出建议来加速吗？我已经添加了一些内容。我想这主要是因为我的文档中有大量的数据。我有大约20个包含数据的选项卡，宏必须在所有可见选项卡中运行，但我不知道如何编写代码来限制这一点

Sub Workbook_Open()

'-----START TIMER-----
Dim StartTime As Double
Dim TimeTaken As String
Dim ws As Worksheet

StartTime = Timer

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False
    Application.StatusBar = False

On Error Resume Next

'For Each ws In ActiveWorkbook.Worksheets ' Start of the VBA loop
For Each ws In Worksheets ' Start of the VBA loop
    With ws
    ws.Activate 'this part ensures each seperate tab is activated and the below code is run through
    Columns("A").ColumnWidth = 0.94 'this line determines the column width
    Columns("B").ColumnWidth = 6.56 'this line determines the column width
    Columns("C").ColumnWidth = 13.56
    Columns("D").ColumnWidth = 13.56
    Columns("E").ColumnWidth = 13.56
    Columns("F").ColxumnWidth = 10.11
    Columns("G").ColumnWidth = 6.11
    Columns("H").ColumnWidth = 10.11
    Columns("I").ColumnWidth = 10.11
    Columns("J").ColumnWidth = 13.56
    Columns("K").ColumnWidth = 6.56
    Columns("L").ColumnWidth = 6.56
    Wsh.Range("A1").Select 'this part ensure each worksheet view start position is A1
    ActiveWindow.View = xlPageBreakPreview 'Set Activesheet to Page Break Preview Mode
    ActiveWindow.Zoom = 114 'this line sets the permanent zoom % for all tabs
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    End With

Next ws
Application.Goto ThisWorkbook.Sheets("resume").Range("A1"), True 'starting position upon opening the file
'Worksheets(1).Activate 'this line make sure view is at first tab

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False
    ActiveWindow.View = xlNormalView

'------ END TIMER------
TimeTaken = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Running time was " & TimeTaken & " (hours, minutes, seconds)"

End Sub

---

您可以尝试以下方法，我只是在运行循环之前将ScreenUpdate、EnableEvents和DisplayAlerts修改为False，然后在完成后将它们重置为True：

Sub Workbook_Open()

'-----START TIMER-----
Dim StartTime As Double
Dim TimeTaken As String
Dim ws As Worksheet

StartTime = Timer

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

'For Each ws In ActiveWorkbook.Worksheets ' Start of the VBA loop
For Each ws In Worksheets ' Start of the VBA loop
        ws.Columns("A").ColumnWidth = 0.94 'this line determines the column width
        ws.Columns("B").ColumnWidth = 6.56 'this line determines the column width
        ws.Columns("C").ColumnWidth = 13.56
        ws.Columns("D").ColumnWidth = 13.56
        ws.Columns("E").ColumnWidth = 13.56
        ws.Columns("F").ColxumnWidth = 10.11
        ws.Columns("G").ColumnWidth = 6.11
        ws.Columns("H").ColumnWidth = 10.11
        ws.Columns("I").ColumnWidth = 10.11
        ws.Columns("J").ColumnWidth = 13.56
        ws.Columns("K").ColumnWidth = 6.56
        ws.Columns("L").ColumnWidth = 6.56
        ws.Range("A1").Select 'this part ensure each worksheet view start position is A1
        ActiveWindow.Zoom = 114 'this line sets the permanent zoom % for all tabs
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = 1
Next ws


Application.Goto ThisWorkbook.Sheets("resume").Range("A1"), True 'starting position upon opening the file

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    ActiveWindow.View = xlNormalView

'------ END TIMER------
TimeTaken = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Running time was " & TimeTaken & " (hours, minutes, seconds)"

End Sub

---

通过在一个步骤中设置多个列的列宽，可以提高宏速度

e、 g.柱A:J.柱宽=13.56

---

要从Xabier已经完成的工作中进一步加快进程，您可以同时执行多个列宽。 有一些是相同的，所以将它们分组是一个好主意

另外，您真的需要在每次打开工作簿时都这样做吗？我的意思是，如果只设置一次宽度，为什么下次打开工作簿时需要再次更改宽度

Sub Workbook_Open()

'-----START TIMER-----
Dim StartTime As Double
Dim TimeTaken As String
Dim ws As Worksheet

StartTime = Timer

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

'For Each ws In ActiveWorkbook.Worksheets ' Start of the VBA loop
For Each ws In Worksheets ' Start of the VBA loop
    If ws.Visible = True Then ' is worksheet visible?
        ws.Columns("A").ColumnWidth = 0.94 'this line determines the column width
        ws.Range("B:B,K:L").ColumnWidth = 6.56 'this line determines the column width
        ws.Range("C:E,J:J").ColumnWidth = 13.56
        ws.Range("F:F,H:I").ColumnWidth = 10.11
        ws.Columns("G").ColumnWidth = 6.11
        ws.Range("A1").Select 'this part ensure each worksheet view start position is A1
        ActiveWindow.Zoom = 114 'this line sets the permanent zoom % for all tabs
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = 1
   end if
Next ws


Application.Goto ThisWorkbook.Sheets("resume").Range("A1"), True 'starting position upon opening the file

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    ActiveWindow.View = xlNormalView

'------ END TIMER------
TimeTaken = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Running time was " & TimeTaken & " (hours, minutes, seconds)"

End Sub

这意味着它将用五行代码而不是12行代码更改所有列宽

您还可以先检查列宽是否需要更改，然后再进行更改

Sub Workbook_Open()

'-----START TIMER-----
Dim StartTime As Double
Dim TimeTaken As String
Dim ws As Worksheet

StartTime = Timer

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

'For Each ws In ActiveWorkbook.Worksheets ' Start of the VBA loop
For Each ws In Worksheets ' Start of the VBA loop
    If ws.Visible = True Then' is worksheet visible?
        if ws.Columns("A").ColumnWidth <> 0.94 and ws.Range("B:B,K:L").ColumnWidth <> 6.56 and ws.Range("F:F,H:I").ColumnWidth <> 10.11 and ws.Columns("G").ColumnWidth <> 6.11 then
            ws.Columns("A").ColumnWidth = 0.94 'this line determines the column width
            ws.Range("B:B,K:L").ColumnWidth = 6.56 'this line determines the column width
            ws.Range("C:E,J:J").ColumnWidth = 13.56
            ws.Range("F:F,H:I").ColumnWidth = 10.11
            ws.Columns("G").ColumnWidth = 6.11
        end if

        ws.Range("A1").Select 'this part ensure each worksheet view start position is A1
        ActiveWindow.Zoom = 114 'this line sets the permanent zoom % for all tabs
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = 1
   end if
Next ws


Application.Goto ThisWorkbook.Sheets("resume").Range("A1"), True 'starting position upon opening the file

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    ActiveWindow.View = xlNormalView

'------ END TIMER------
TimeTaken = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Running time was " & TimeTaken & " (hours, minutes, seconds)"

End Sub

---

宏开始和结束时以应用程序、屏幕更新等开头的块应该完全切换。您希望在宏运行期间关闭屏幕更新、事件和警报。但是现在你可以特别地打开所有的开关，然后在它结束时关闭。这很有帮助。代码现在需要1:23分钟，但仍然太长。我看到了如何使我的循环更有效率，但不确定如何解决这个问题。例如，仅在可见的工作表上运行代码？@Xabier让OP接受他/她喜欢的答案，而无需说服。您的ws不应包括范围activewindow部件。而且射程缺少一个。在它之前。谢谢！忘了那两个。我在其他代码中也遇到了同样的问题，但忘记了if语句。好吧，文档有多个用户，人们将开始调整宽度。高级管理层不想打开文档，他们自己也必须再次调整宽度

Sub Workbook_Open()

'-----START TIMER-----
Dim StartTime As Double
Dim TimeTaken As String
Dim ws As Worksheet

StartTime = Timer

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

'For Each ws In ActiveWorkbook.Worksheets ' Start of the VBA loop
For Each ws In Worksheets ' Start of the VBA loop
    If ws.Visible = True Then' is worksheet visible?
        if ws.Columns("A").ColumnWidth <> 0.94 and ws.Range("B:B,K:L").ColumnWidth <> 6.56 and ws.Range("F:F,H:I").ColumnWidth <> 10.11 and ws.Columns("G").ColumnWidth <> 6.11 then
            ws.Columns("A").ColumnWidth = 0.94 'this line determines the column width
            ws.Range("B:B,K:L").ColumnWidth = 6.56 'this line determines the column width
            ws.Range("C:E,J:J").ColumnWidth = 13.56
            ws.Range("F:F,H:I").ColumnWidth = 10.11
            ws.Columns("G").ColumnWidth = 6.11
        end if

        ws.Range("A1").Select 'this part ensure each worksheet view start position is A1
        ActiveWindow.Zoom = 114 'this line sets the permanent zoom % for all tabs
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = 1
   end if
Next ws


Application.Goto ThisWorkbook.Sheets("resume").Range("A1"), True 'starting position upon opening the file

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    ActiveWindow.View = xlNormalView

'------ END TIMER------
TimeTaken = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Running time was " & TimeTaken & " (hours, minutes, seconds)"

End Sub