如何优化慢速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)

数组中的数字正是您的"案例"条件。您应该将此列表扩展到 130，这是您的最后一个"案例"。借助此工具，您现在可以将所有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 函数从随机数范围返回一个连续的数字。