如何優化緩慢的VBA代碼Excel

也許我太過挑剔，但我的宏需要1秒左右的時間才能在強大的筆記本電腦上運行（數據很少）。但它會運行在平均速度慢的PC上。如何優化緩慢的VBA代碼Excel

有沒有一種方法來優化此代碼？你認爲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

來源

2017-04-14 Wilson Méndez Peñalosa

你很多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函數從一系列隨機數中返回一個連續的數字。

來源

2017-04-14 06:05:36 Variatus

令人驚歎！謝謝！！！ –

如何優化緩慢的VBA代碼Excel

回答

相關問題