beschleunigen Excel UDF

Question

ich eine grundlegende UDF haben, die mehrere Übereinstimmungen für eine vlookup verkettet im Grunde

  Function MYVLOOKUP(lookupval, lookuprange As Range, indexcol1 As Long, indexcol2 As Long, indexcol3 As Long) 
      'disable slow apps 
      Application.ScreenUpdating = False 
      Application.DisplayStatusBar = False 
      Application.EnableEvents = False 
      ActiveSheet.DisplayPageBreaks = False 

      'main code 
      Dim r As Range 
      Dim result As String 
      'set string to null instead of nothing 
      result = vbNullString 
      For Each r In lookuprange 
       If r = lookupval Then 
        result = result & " " & r.Offset(0, indexcol1 - 1) & " " & r.Offset(0, indexcol2 - 1) & " " & r.Offset(0, indexcol3 - 1) & "|" 
       End If 
      Next r 
      'output results 
      MYVLOOKUP = result 

      'enable apps 
      Application.ScreenUpdating = True 
      Application.DisplayStatusBar = True 
      Application.EnableEvents = True 
      ActiveSheet.DisplayPageBreaks = True 

      'end function 
      End Function 

Gibt es eine Möglichkeit, dies zu beschleunigen, mein Chef will keine neuen Daten oder Spalten hinzufügen zu die Tabelle so muss es diese Funktion sein. Aber das dauert über 320000 Zellen dauert eine lange Zeit.

Alle Hilfe ist willkommen.

UPDATE: hinzugefügt einige Code zu beschleunigen, aber immer noch langsam

Die Daten werden auf diese Weise

 Sheet 1 
    1 | | 
    2 | | 
    3 | | 
    4 | | 
    5 | | 
    6 | | 
    7 | | 
    Sheet 2 
    1 |1a  |b  |c 
    1 |1ab |bb  |cc 
    1 |1abc |bbb |cccc 
    1 |abcd |bbbb |cccc 
    2 |a  |b  |c 
    2 |ab  |bb  |cc 
    2 |abc |bbb |cccc 
    2 |abcd |bbbb |cccc 
    3 |a  |b  |c 
    3 |ab  |bb  |cc 
    4 |a  |b  |c 
    5 |a  |b  |c 
    6 |a  |b  |c 
    7 |wer |werr |rewsfd 

    i need it to look like this 
    1 |1a b c| 1ab bb cc| 1abc bbb cccc| abcd bbbb cccc| 

es 20 Spalten zu handhaben muss in der Lage sein

Answer 1

Dies legt den Bereich in ein Array, bevor Sie nach dem Wert suchen. Sie können der Rückgabe beliebig viele Spalten hinzufügen, solange sie sich im Bereich der Nachschlagetabelle befinden.

Ich habe es nicht auf einem großen Recordset getestet, aber ein Array wird sicherlich schneller sein?

Public Function MYVLOOKUP(LookUpValue As String, LookUpTable As Range, ParamArray lColumn()) As Variant 

    Dim vTable As Variant 
    Dim x As Long, y As Long 
    Dim lMaxCol As Long 
    Dim sResult As Variant 

    vTable = LookUpTable 

    'Check a column outside the range of LookUpTable isn't being asked for. 
    For x = LBound(lColumn) To UBound(lColumn) 
     If lColumn(x) > lMaxCol Then 
      lMaxCol = lColumn(x) 
     End If 
    Next x 

    If lMaxCol <= LookUpTable.Columns.Count Then 
     'Work through the array looking for the value, and return values from specified array elements. 
     For x = LBound(vTable, 1) To UBound(vTable, 1) 
      If vTable(x, 1) = LookUpValue Then 
       For y = LBound(lColumn) To UBound(lColumn) 
        sResult = sResult & " " & vTable(x, lColumn(y)) 
       Next y 
      End If 
     Next x 
    Else 
     'Column outside the range is asked for - return a #REF error. 
     sResult = CVErr(xlErrRef) 
    End If 

    MYVLOOKUP = sResult 

End Function 

Edit: Frage mich, ob ich das Ganze in ein Hit tun könnte eine Matrixformel verwenden und Application.Caller

Answer 2

Sie führen sie formatiert über 320000 Zellen ... okay. Wie oft führst du es? Ist es eine berechnete Spalte und Sie haben 320K Formeln drin oder haben Sie nur 10 oder 20 Formel? Bitte aktualisieren Sie Ihre Antwort mit Screenshots von Beispieldaten und einem Beispiel der tatsächlichen Formel und ich werde meine Antwort verbessern.

Es macht einen großen Unterschied, wenn LookUpTable eine einzelne Spalte oder mehrere Spalten ist. I LookUpTable ist eine einzelne Spalte, dann verwenden Sie kein UDT. Eine Kombination aus Match und Index ist wahrscheinlich die beste Wahl.

Sie sollten lesen: .

Das Beenden der Funktion nach dem Finden einer Übereinstimmung verbessert die Leistung erheblich.

Function MYVLOOKUP(LookUpValue As String, LookUpTable As Range, Column1 As Long, Column2 As Long, Column3 As Long) As String 
    Dim rng As Range 
    Dim xResult As String 
    xResult = "" 
    For Each rng In LookUpTable 
     If rng = LookUpValue Then 
      MYVLOOKUP = xResult & " " & rng.Offset(0, Column1 - 1) & " " & rng.Offset(0, Column2 - 1) & " " & rng.Offset(0, Column3 - 1) 
      Exit Function 
     End If 
    Next 

End Function 

Answer 3

Sie AutoFilter() Ansatz verwenden:

Function MYVLOOKUP(LookUpValue As String, LookUpTable As Range, Column1 As Long, Column2 As Long, Column3 As Long) As String 
    Dim rng As Range 
    Dim refCol As Long 
    Dim xResult As String 

    With LookUpTable '<--| reference table 
     refCol = .Columns(1).Column '<--| assume referenced table 1st column as column to offset "result" columns from 
     .AutoFilter field:=1, Criteria1:=LookUpValue '<--| filter on referenced table 1st column with given 'LookUpValue ' 
     If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any cell filtered other than header (which is in first row) 
      For Each rng In .Resize(.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible) '<--| loop through table 1st column filtered not empty cells after headers row 
       xResult = xResult & " " & rng.Offset(0, Column1 - refCol) & " " & rng.Offset(0, Column2 - refCol) & " " & rng.Offset(0, Column3 - refCol) 
      Next rng 
     End If 
     .Parent.AutoFilterMode = False 
    End With 
    MYVLOOKUP = xResult 
End Function 

vorausgesetzt:

• LookUpTable kann jeder mehrspaltigen Bereich

• LookUpTable erste Reihe ist "headers"

• Column1, Column2, Column3, sind absolute Spaltenindizes, wobei "Ergebnis" Zellen greifen von

  können sie sogar werden außerhalb LookUpTable Spalten

Answer 4

Matt reichen ist es das, was Sie suchen?

Sub TableFromRelational() 
Dim InArr: InArr = Selection.CurrentRegion.Value 
Dim Coll As Scripting.Dictionary 
Set Coll = New Scripting.Dictionary 
Dim RsltArr 
Dim I As Long 
For I = LBound(InArr) To UBound(InArr) 
Dim Key As Double: Key = InArr(I, LBound(InArr, 2)) 
If Coll.Exists(Key) Then 
RsltArr = Coll(Key) 
ReDim Preserve RsltArr(UBound(RsltArr) + 1) 
Coll.Remove Key 
Else 
ReDim RsltArr(0) 
End If 
RsltArr(UBound(RsltArr)) = InArr(I, LBound(InArr, 2) + 1) 
Coll.Add Key, RsltArr 
Next I 
Dim DestRng As Range 
With Selection.CurrentRegion 
Set DestRng = .Offset(0, .Columns.Count + 1).Cells(1, 1) 
End With 
DestRng.Resize(Coll.Count, 1).Value = Application.WorksheetFunction.Transpose(Coll.Keys) 
For I = 0 To Coll.Count - 1 
RsltArr = Coll(Coll.Keys(I)) 
DestRng.Offset(I, 1).Resize(1, UBound(RsltArr) + 1).Value = RsltArr 
Next I 
End Sub