VBA - Help Needed - Macro SpeedUp

[mitko007]

Hi guys,
i need help with speeding up a Scirpt that i have written. The script reads data from Sheet1 and Copies it sorted in Sheet2 as shown in the image.

Capture.jpg

As the input data is quite large i need to wait long before it does all the checks and fills in the data. I think that it could be much faster if using Arrays or Dictionaries or something similar, however i lack in knowledge to implement this.

Attached you can find my code as well:

I would appreciate your help.

Thanks and BR

Sub Order_List()
Application.ScreenUpdating = False

Dim RcountT1 As Long

RcountT1 = Worksheets("Tabelle1").Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("Tabelle1").Range("A2:A" & RcountT1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets("Tabelle3").Range("A6"), Unique:=True

RcountT3 = Worksheets("Tabelle3").Cells(Rows.Count, "A").End(xlUp).Row

For i = 6 To RcountT3
    For j = 2 To RcountT1
    If Worksheets("Tabelle3").Cells(i, 1) = Worksheets("Tabelle1").Cells(j, 1) Then
    Worksheets("Tabelle3").Cells(i, 2) = Worksheets("Tabelle1").Cells(j, 2)
    CcountT3 = Worksheets("Tabelle3").Cells(i, Columns.Count).End(xlToLeft).Column
    Worksheets("Tabelle3").Cells(i, CcountT3 + 1) = Worksheets("Tabelle1").Cells(j, 3)
    End If
    Next j
Next i

LastCol = Worksheets("Tabelle3").UsedRange.Columns.Count

m = 1

For colnum = 3 To LastCol
Worksheets("Tabelle3").Cells(5, colnum) = "Tag " & m
m = m + 1
Next colnum

Application.ScreenUpdating = True
End Sub

[mana]

Option Explicit


Sub test()
    Dim dic As Object
    Dim wsS As Worksheet
    Dim wsD As Worksheet
    Dim i As Long
    Dim v
    Dim s, k
    Dim n As Long, m As Long
    
    Set dic = CreateObject("scripting.dictionary")
    
    Set wsS = Worksheets("Tabelle1")
    Set wsD = Worksheets("Tabelle3")
    
    v = wsS.Cells(1).CurrentRegion.Value

    For i = 2 To UBound(v)
        s = v(i, 1)
        If Not dic.exists(s) Then
            Set dic(s) = CreateObject("system.collections.arraylist")
            dic(s).Add v(i, 1)
            dic(s).Add v(i, 2)
        End If
        dic(s).Add v(i, 3)
    Next
    
    n = 5
    For Each k In dic.keys
        n = n + 1
        wsD.Cells(n, 1).Resize(, dic(k).Count).Value = dic(k).toarray
        m = WorksheetFunction.Max(m, dic(k).Count)
    Next
    
    With wsD.Cells(5, 3)
        .Value = "Tag 1"
        .AutoFill .Resize(, m - 2)
    End With

End Sub

[mitko007]

Option Explicit


Sub test()
    Dim dic As Object
    Dim wsS As Worksheet
    Dim wsD As Worksheet
    Dim i As Long
    Dim v
    Dim s, k
    Dim n As Long, m As Long
    
    Set dic = CreateObject("scripting.dictionary")
    
    Set wsS = Worksheets("Tabelle1")
    Set wsD = Worksheets("Tabelle3")
    
    v = wsS.Cells(1).CurrentRegion.Value

    For i = 2 To UBound(v)
        s = v(i, 1)
        If Not dic.exists(s) Then
            Set dic(s) = CreateObject("system.collections.arraylist")
            dic(s).Add v(i, 1)
            dic(s).Add v(i, 2)
        End If
        dic(s).Add v(i, 3)
    Next
    
    n = 5
    For Each k In dic.keys
        n = n + 1
        wsD.Cells(n, 1).Resize(, dic(k).Count).Value = dic(k).toarray
        m = WorksheetFunction.Max(m, dic(k).Count)
    Next
    
    With wsD.Cells(5, 3)
        .Value = "Tag 1"
        .AutoFill .Resize(, m - 2)
    End With

End Sub

Thanks mana. Works perfect.

I owe you one..

BR