Consulting

Results 1 to 3 of 3

Thread: VBA - Help Needed - Macro SpeedUp

  1. #1
    VBAX Regular
    Joined
    Jul 2008
    Posts
    51
    Location

    VBA - Help Needed - Macro SpeedUp

    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
    


  2. #2
    VBAX Expert
    Joined
    Sep 2016
    Posts
    618
    Location
    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

  3. #3
    VBAX Regular
    Joined
    Jul 2008
    Posts
    51
    Location
    Quote Originally Posted by mana View Post
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •