stackoom
  简体   繁体   中英

How to optimize slow VBA code Excel

 原文  2017-04-14 05:06:42  9   1    excel-vba/ vba/ excel

Question

Maybe I'm being too fussy, but my macro takes about 1 second to run in a powerfull laptop (with little data). But it will run on average-slow performance pc's.

Is there a way to optimize this code? Do you think Select Case is slowing down the execution? If so, how can I improve it?

Sorry for the extension of the code.

Thank you. 

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

1 answers

solution1
 1 ACCPTED  2017-04-14 06:05:36

Your many Select Case statements would indeed eat up a lot of time. At a quick glance, there is a firm relationship between the Case and the result. The following example shows how you could compress all your Select statements in the K-loop into a single statement. 

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

Unfortunately, the relationship isn't always -1 . Therefore I suggest that you declare an array before you enter the K-loop, like this:- 

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

The numbers in the array are exactly your 'Case' conditions. You should extend this list up to 130 which is your last 'Case'. With the help of this tool you can now replace all the Case statements with just one:- 

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

An error will occur if a match isn't found. Match will return the number of the element in the array which, it so happens, is the row number you need. You could modify this if required. The point is that the Match function returns a consecutive number from a range of random numbers.

暂无
暂无

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

Related Question How to optimize Excel VBA code Need to optimize a slow vba code How to Optimize Excel VBA Formula VBA excel, a lot of flickering and a bit slow, help me optimize How to optimize the performance of the VBA code? CountIFs in Excel whit VBA Code is very slow VBA/Excel suddenly running slow with no code changes Excel VBA SUMIF Super slow code Excel 2010 VBA - How to optimize this code so it doesn't lag out? How to optimize specific vba code speed?
Related Tags
 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM