Как оптимизировать код VB ниже? Запуск занимает много времени и Excel зависает каждый раз - PullRequest
Новая
       29

Как оптимизировать код VB ниже? Запуск занимает много времени и Excel зависает каждый раз

0 голосов
/ 04 июля 2018

Я создаю матрицу Traceablity M требования в листе Excel, и ниже код VB требует больше времени для выполнения, и лист Excel зависает на 5 минут каждый раз, когда я вношу что-то в ячейку.

код VBA: 

Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer)

    Dim xDic As New Dictionary
    Dim xRows As Long
    Dim xStr As String
    Dim i As Long

    On Error Resume Next
    xRows = LookupRange.Rows.Count
    For i = 1 To xRows
        If LookupRange.Columns(1).Cells(i).Value = Lookupvalue Then
            xDic.Add LookupRange.Columns(ColumnNumber).Cells(i).Value, ""
        End If
    Next
    xStr = ""
    MultipleLookupNoRept = xStr
    If xDic.Count > 0 Then
        For i = 0 To xDic.Count - 1
            xStr = xStr & xDic.Keys(i) & ","
        Next
        MultipleLookupNoRept = Left(xStr, Len(xStr) - 1)
    End If 

End Function

1 Ответ

0 голосов
/ 04 июля 2018

↓ Объединить все ключи в словаре ↓ 

Join(Dictionary.Key(), ",")

Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer) As String

    Dim xDic As New Dictionary
    Dim xRows As Long
    Dim xStr As String
    Dim i As Long

    On Error Resume Next
    xRows = LookupRange.Rows.count
    For i = 1 To xRows
        If LookupRange.Columns(1).Cells(i).Value = Lookupvalue Then
            xDic.Add LookupRange.Columns(ColumnNumber).Cells(i).Value, ""
        End If
    Next

    If xDic.count > 0 Then
        MultipleLookupNoRept = Join(xDic.Keys(), ",")
    End If

End Function

Вот ультра-модифицированная версия кода. Предыдущий код должен обрабатывать 10K строк за 2-5 секунд. 

Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer) As String

    Dim addresses As Variant, values As Variant
    Dim r As Long

    With LookupRange.Parent
        With Intersect(LookupRange.Columns(1), .UsedRange)
            values = .Value
            addresses = .Columns(ColumnNumber).Value
        End With
    End With

    With CreateObject("System.Collections.ArrayList")
        For r = 1 To UBound(values)
            If values(r, 1) = Lookupvalue And r <= UBound(addresses) And addresses(r, 1) <> "" Then
                .Add addresses(r, 1)
            End If
        Next

        MultipleLookupNoRept = Join(.ToArray(), ",")
    End With

End Function
...