堆栈内存溢出
  简体   繁体   English

如何优化慢速VBA代码Excel

[英]How to optimize slow VBA code Excel

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

问题描述

Maybe I'm being too fussy, but my macro takes about 1 second to run in a powerfull laptop (with little data). 也许我太挑剔了，但是我的宏大约需要1秒钟才能在功能强大的笔记本电脑（几乎没有数据）中运行。 But it will run on average-slow performance pc's. 但是它将在平均性能较慢的PC上运行。

Is there a way to optimize this code? 有没有一种方法可以优化此代码？ Do you think Select Case is slowing down the execution? 您是否认为Select Case正在减慢执行速度？ 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 个解决方案

解决方案1
 1 已采纳  2017-04-14 06:05:36

Your many Select Case statements would indeed eat up a lot of time. 您的许多Select Case语句确实会消耗大量时间。 At a quick glance, there is a firm relationship between the Case and the result. 乍一看， Case与结果之间存在牢固的关系。 The following example shows how you could compress all your Select statements in the K-loop into a single statement. 下面的示例说明如何将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

Unfortunately, the relationship isn't always -1 . 不幸的是，这种关系并不总是-1 。 Therefore I suggest that you declare an array before you enter the K-loop, like this:- 因此，我建议您在进入K循环之前先声明一个数组，如下所示： 

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'. 您应该将此列表扩展到130，这是您的最后一个“案例”。 With the help of this tool you can now replace all the Case statements with just one:- 借助此工具，您现在可以将所有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

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. Match将返回数组中元素的编号，恰好是您需要的行号。 You could modify this if required. 您可以根据需要对此进行修改。 The point is that the Match function returns a consecutive number from a range of random numbers. 关键是Match函数从一系列随机数中返回一个连续数。

暂无
暂无

声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

相关问题 如何优化Excel VBA代码 - How to optimize Excel VBA code 需要优化慢速vba代码 - Need to optimize a slow vba code 如何优化Excel VBA公式 - How to Optimize Excel VBA Formula VBA excel，很多闪烁，有点慢，可以帮助我优化 - VBA excel, a lot of flickering and a bit slow, help me optimize 如何优化VBA代码的性能？ - How to optimize the performance of the VBA code? Excel的VBA代码中的CountIF非常慢 - CountIFs in Excel whit VBA Code is very slow VBA / Excel突然运行缓慢，没有代码更改 - VBA/Excel suddenly running slow with no code changes Excel VBA SUMIF超级慢代码 - Excel VBA SUMIF Super slow code Excel 2010 VBA - 如何优化此代码以使其不会滞后？ - Excel 2010 VBA - How to optimize this code so it doesn't lag out? 如何优化特定的VBA代码速度？ - How to optimize specific vba code speed?
相关标签
 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM