如何优化慢速VBA代码Excel

Question

也许我太挑剔了，但是我的宏需要大约1秒才能在强大的笔记本电脑中运行（数据很少）。但它将在平均 - 慢性能PC上运行。

有没有办法优化此代码？你认为Select Case是否会减慢执行速度？如果是这样，我该如何改进呢？

很抱歉代码扩展。

谢谢。

Private Sub crear_Click()

Dim ctrl As Control, ctrl2 As Control, aler As Variant, ws As Worksheet, ws2 As Worksheet, ultimafila As Double, ultimaFila2 As Double, i As Integer, pPage As MSForms.Page, N As Double, selectedItems As String, valorProbabilidad As Integer, valorImpacto As Integer, valorMagnitud As Integer, resta As Long, ultimaFila3 As Long, j As Long, ultimaFila4 As Long, k As Double, l As Double

Set ws = Worksheets("Valoración"): Set ws2 = Worksheets("lista_riesgos")

ultimafila = ws.ListObjects("Riesgos").Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
ultimaFila2 = ws2.ListObjects("consolidadoRiesgos").Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
ultimaFila3 = ws2.ListObjects("consolidadoRiesgos").Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1
ultimaFila4 = ws2.ListObjects("Riesgo").Range.Columns(2).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1
resta = 0.5

With Me
    For Each ctrl In .Controls
        If Left(ctrl.Name, 5) = "texto" Then
            If Trim(ctrl.Value & vbNullString) = vbNullString Then
                aler = Replace(ctrl.Name, "texto", "alerta")
                .Controls(aler).Visible = True
            End If
        ElseIf Left(ctrl.Name, 5) = "lista" Then
            For N = 0 To listaObjetivos.ListCount - 1
                If listaObjetivos.Selected(N) Then GoTo algoSeleccionado
            Next N
            aler = Replace(ctrl.Name, "lista", "alerta")
            .Controls(aler).Visible = True
            GoTo salir
algoSeleccionado:
            aler = Replace(ctrl.Name, "lista", "alerta")
            .Controls(aler).Visible = False
            GoTo continuar
salir:
        End If
    Next ctrl
    Exit Sub
End With

continuar:

Select Case Me.textoFrecuencia
    Case "Casi seguro"
        valorProbabilidad = 5
    Case "Probable"
        valorProbabilidad = 4
    Case "Posible"
        valorProbabilidad = 3
    Case "Improbable"
        valorProbabilidad = 2
    Case "Raro"
        valorProbabilidad = 1
End Select

Select Case Me.textoImpacto
    Case "Catastrófico"
        valorImpacto = 5
    Case "Mayor"
        valorImpacto = 4
    Case "Moderado"
        valorImpacto = 3
    Case "Menor"
        valorImpacto = 2
    Case "Insignificante"
        valorImpacto = 1
End Select

valorMagnitud = valorProbabilidad * valorImpacto

With ws
    .Unprotect Password:="pAtRiCiA"
    For Each ctrl In Me.Controls
        If Left(ctrl.Name, 5) = "texto" Then
            .Cells(ultimafila, ctrl.TabIndex) = ctrl.Value
        End If
    Next ctrl

    For i = 0 To listaObjetivos.ListCount - 1
        If listaObjetivos.Selected(i) = True Then
            ws.Cells(ultimafila, (i) + 6) = "X"
            'selectedItems = selectedItems & listaObjetivos.List(i) & (i) & vbNewLine
        End If
    Next i

    Select Case valorMagnitud
        Case Is >= 15
            .Cells(ultimafila, 25) = "Extremo"
        Case 8 To 14
            .Cells(ultimafila, 25) = "Alto"
        Case 4 To 7
            .Cells(ultimafila, 25) = "Medio"
        Case 1 To 3
            .Cells(ultimafila, 25) = "Aceptable"
    End Select

    .Rows(ultimafila).AutoFit
    .Rows(ultimafila).RowHeight = .Cells(ultimafila, 1).Height + 12
    .Protect Password:="pAtRiCiA", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With

With ws2

    .Unprotect Password:="pAtRiCiA"
    .Cells(ultimaFila2, 1) = (valorProbabilidad * valorProbabilidad * valorProbabilidad) + valorImpacto
    .Cells(ultimaFila2, 2) = Me.textoCodigo

    .ListObjects("Riesgo").DataBodyRange.Columns(1).ClearContents

    For k = 1 To ultimaFila3

        Select Case .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 1).Value
            Case 2
                If .ListObjects("Riesgo").DataBodyRange.Cells(1, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(1, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(1, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(1, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 3
                If .ListObjects("Riesgo").DataBodyRange.Cells(2, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(2, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(2, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(2, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 4
                If .ListObjects("Riesgo").DataBodyRange.Cells(3, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(3, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(3, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(3, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 5
                If .ListObjects("Riesgo").DataBodyRange.Cells(4, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(4, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(4, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(4, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 6
                If .ListObjects("Riesgo").DataBodyRange.Cells(5, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(5, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(5, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(5, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 9
                If .ListObjects("Riesgo").DataBodyRange.Cells(6, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(6, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(6, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(6, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 10
                If .ListObjects("Riesgo").DataBodyRange.Cells(7, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(7, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(7, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(7, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 11
                If .ListObjects("Riesgo").DataBodyRange.Cells(8, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(8, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(8, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(8, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 12
                If .ListObjects("Riesgo").DataBodyRange.Cells(9, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(9, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(9, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(9, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 13
                If .ListObjects("Riesgo").DataBodyRange.Cells(10, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(10, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(10, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(10, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 28
                If .ListObjects("Riesgo").DataBodyRange.Cells(11, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(11, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(11, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(11, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 29
                If .ListObjects("Riesgo").DataBodyRange.Cells(12, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(12, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(12, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(12, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 30
                If .ListObjects("Riesgo").DataBodyRange.Cells(13, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(13, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(13, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(13, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 31
                If .ListObjects("Riesgo").DataBodyRange.Cells(14, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(14, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(14, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(14, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 32
                If .ListObjects("Riesgo").DataBodyRange.Cells(15, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(15, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(15, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(15, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 65
                If .ListObjects("Riesgo").DataBodyRange.Cells(16, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(16, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(16, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(16, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 66
                If .ListObjects("Riesgo").DataBodyRange.Cells(17, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(17, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(17, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(17, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 67
                If .ListObjects("Riesgo").DataBodyRange.Cells(18, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(18, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(18, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(18, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 68
                If .ListObjects("Riesgo").DataBodyRange.Cells(19, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(19, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(19, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(19, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 69
                If .ListObjects("Riesgo").DataBodyRange.Cells(20, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(20, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(20, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(20, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 126
                If .ListObjects("Riesgo").DataBodyRange.Cells(21, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(21, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(21, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(21, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 127
                If .ListObjects("Riesgo").DataBodyRange.Cells(22, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(22, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(22, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(22, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 128
                If .ListObjects("Riesgo").DataBodyRange.Cells(23, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(23, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(23, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(23, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 129
                If .ListObjects("Riesgo").DataBodyRange.Cells(24, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(24, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(24, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(24, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If
            Case 130
                If .ListObjects("Riesgo").DataBodyRange.Cells(25, 1) = Empty Then
                    .ListObjects("Riesgo").DataBodyRange.Cells(25, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                Else
                    .ListObjects("Riesgo").DataBodyRange.Cells(25, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(25, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
                End If

            End Select
    Next k
    .Protect Password:="pAtRiCiA", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With

For j = 0 To listaObjetivos.ListCount - 1
    listaObjetivos.Selected(j) = False
Next

Me.textoCodigo = Null
Me.textoTipo = Null
Me.textoResponsable = Null
Me.textoDescripcion = Null
Me.textoDetalle = Null
Me.textoControles = Null
Me.textoFrecuencia = Null
Me.textoEscala = Null
Me.textoImpacto = Null

End Sub

Answer 1

你的许多Select Case陈述确实会耗费大量时间。快速浏览一下，Case与结果之间存在牢固的关系。以下示例显示了如何将K循环中的所有Select语句压缩为单个语句。

Dim R As Long
R = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 1).Value
If .ListObjects("Riesgo").DataBodyRange.Cells(1, 1) = Empty Then
    .ListObjects("Riesgo").DataBodyRange.Cells(R - 1, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 2)
Else
    .ListObjects("Riesgo").DataBodyRange.Cells(R - 1, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(R - 1, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 2)
End If

不幸的是，这种关系始终不是-1。因此，我建议您在进入K循环之前声明一个数组，如下所示： -

Dim Clm() As Variant
Clm = Array(2, 3, 4, 5, 6, 9, 10, 11, 12, 13, 28)

数组中的数字正是您的案例＆＃39;条件。您应该将此列表扩展到130，这是您的最后一个案例＆＃39;。借助此工具，您现在可以只用一个代替所有Case语句： -

Dim Clm() As Variant                ' Place your Dim statements
Dim C As Long, R As Long            ' at the top of your code

Clm = Array(2, 3, 4, 5, 6, 9, 10, 11, 12, 13, 28)

' start the K-loop here

C = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 1).Value
R = Application.Match(C, Clm, 0)
With .ListObjects("Riesgo").DataBodyRange
    If .Cells(1, 1) = Empty Then
        .Cells(R, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 2)
    Else
        .Cells(R, 1) = .Cells(R, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 2)
    End If
End With

如果找不到匹配项，则会发生错误。 Match将返回数组中元素的编号，它恰好是您需要的行号。如果需要，您可以修改它。关键是Match函数从一系列随机数中返回一个连续的数字。