遅い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文を単一の文に圧縮する方法を示しています。

残念ながら、関係は必ずしも-1ではありません。

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

、アレイ内の数字は正確にあなたの「ケース」条件である - ：したがって、私はあなたがK-ループに入る前に、あなたはこのように、配列を宣言することを示唆しています。このリストを最後の「ケース」である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関数が一連の乱数から連続した数値を返すことです。