PDA

View Full Version : [SOLVED] VBA - Help Needed - Macro SpeedUp



mitko007
06-13-2018, 04:54 AM
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.

22415

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
06-13-2018, 06:04 AM
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
06-13-2018, 06:13 AM
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