如何提高VBA代码的速度和效率

我正在尝试构建一个Excel工作簿，以自动并帮助创建每周工作计划。

我目前的工作手册很实用，但速度很慢——特别是在一项任务中，我有一份年度计划表，我同时搜索了两张工作表

我认为有一种比我现在使用的更好、更有效的方法

Option Explicit

'Global variable that will be in another module where I store all general config

Public Const PlanningAgentEmptyRange        As String = "C12:G58,F74:G78" 'Range agent present
Public Const PosteWeekDayRange               As String = "B12:B72" 'Range agent present
Public Const PosteWeekEndRange               As String = "B73:B78" 'Range agent present


Sub DraftFromCycle()

    'If range is empty (to prevent the lost of approved schedule)
    If Application.WorksheetFunction.CountA(Range(PlanningAgentEmptyRange)) = 0 Then

        'list of day/col Weekday in weekly schedule
        Dim aWeekDay(1 To 5) As String
        aWeekDay(1) = "C": aWeekDay(2) = "D": aWeekDay(3) = "E": aWeekDay(4) = "F": aWeekDay(5) = "G"

        'List of day/col weekEnd in weekly schedule
        Dim aWeekEnd(1 To 2) As String
        aWeekEnd(1) = "F": aWeekEnd(2) = "G"

        Dim DayDate As Range
        Dim cel As Range
        Dim Col As Variant
        Dim DayRangeCycle As Range
        Dim DayCycleCol As String
        Dim DayCycleRow As Integer
        Dim AgentName
        Dim p, s, poste, x As Variant
        Dim Cycle_lastrow As Integer
        Dim Cycle_lastcol As String


        Cycle_lastrow = LastRow(Feuil55)
        Cycle_lastcol = lastCol(Feuil55)


        'Loop col/Day  of weekday
        For Each Col In aWeekDay

            Set DayDate = Range(Col & "11")
            Set s = Worksheets("Cycle").Range("A5:OA5").Find(What:=DayDate, Lookat:=xlWhole)
            If Not s Is Nothing Then
                DayCycleCol = ColLetter(s.Column)

                For Each poste In Worksheets("Cycle").Range(DayCycleCol & "6:" & DayCycleCol & Cycle_lastrow)

                    Select Case poste
                    Case Is = "AM"
                        Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="Après-midi", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Is = "N"
                        Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="Nuit", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Is = "R N"
                        Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="Récup Nuit", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Is = "R Av"
                        Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="R.H. Avant Garde", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Is = "R Ap"
                        Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="R.H. Après Garde", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Is = "RTP"
                        Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="R.T.P.", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Else
                    End Select

                Next poste
            End If
        Next Col

        'Loop col du Week End
        For Each Col In aWeekEnd

            Set DayDate = Range(Col & "73")
            Set s = Worksheets("Cycle").Range("A5:OA5").Find(What:=DayDate, Lookat:=xlWhole)
            If Not s Is Nothing Then
                DayCycleCol = ColLetter(s.Column)

                For Each poste In Worksheets("Cycle").Range(DayCycleCol & "6:" & DayCycleCol & Cycle_lastrow)

                    Select Case poste
                    Case Is = "AM"
                        Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="Après-midi", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Is = "N"
                        Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="Nuit", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Is = "6h25"
                        Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="6h25 - 13h25", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Is = "7h30"
                        Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="7h30 - 14h30", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Is = "7h45"
                        Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="7h45 - 14h45", Lookat:=xlWhole)
                        If Not x Is Nothing Then
                            Do
                                If ActiveSheet.Range(Col & x.row) = "" Then
                                    ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
                                    ActiveSheet.Range(Col & x.row).Font.Italic = True
                                End If
                                Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
                            Loop While Not x Is Nothing
                        End If

                    Case Else
                    End Select

                Next poste
            End If
        Next Col

    End If
End Sub

这是一个屏幕，显示床单的样子 该模块从年度计划中获取数据，如果周计划为空，则自动填充周计划

年度计划（工作表（“周期”））

每周时间表（工作表（“1”））

---

您可能希望首先使用

Application.screenUpdate=False

和

Application.EnableEvents=False

。也就是说，这可能更适合于“无响应”意味着VBA正忙于运行您的代码；即使是最高效的代码也会使Excel在运行时“不响应”。不要把“没有反应”当作任何事情的暗示。也就是说，您的代码可能确实可以变得更高效，但这是-protip的工作：您需要使用一个描述代码用途的帖子标题，因为那里的每个人都希望“更改代码以使其运行更流畅”；-）如果您的代码正常工作，并且您只是希望对其进行改进，那么您的问题应该改为继续提问。请在提问之前修复您的缩进review@Jmeyer您关闭了Application.ScreenUpdate和EnableEvents，然后脚本花了10分钟，还是忘记重新打开它们？