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
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