this code become slow for 18000 rows despite of using dictionary and array

[leap out]

Hi experts
I got help from mr.Peter_Ss with some modification .
the code becomes more slowly when test for big data, despite of using dictionary & array
so the big data can be 18000 rows for each sheet . the code will calculation items based on column B and if there is duplicates items should merge for each sheet . the formula will be (stock-sales+pur-return) in sheet summary for last column ,also if there is new item in one of sheets but is not in another , then should also show and calculation . the code create whole data with format & borders and collect the data across sheet into sheet summary

Sub CollateData_v4()
  Dim d As Object
  Dim ShList As Variant, a As Variant, vals As Variant
  Dim i As Long, j As Long
  Dim s As String
 
  Set d = CreateObject("Scripting.Dictionary")
  ShList = Split("stock|sales|pur|returns", "|")
  For j = 0 To UBound(ShList)
    With Sheets(ShList(j))
      a = .UsedRange.Value2
      For i = 2 To UBound(a)
        s = .Cells(i, 2)
        If Len(s) > 2 Then
         
        If Not d.exists(s) Then d(s) = Join(Application.Index(a, i, Array(3, 4, 5)), ";") & ";;;;"
          vals = Split(d(s), ";")
          If IsNumeric(vals(j + 3)) Then
           vals(j + 3) = vals(j + 3) + a(i, 6)
           Else
           vals(j + 3) = a(i, 6)
          End If
         
            d(s) = Join(vals, ";")
         
        End If
      Next i
    End With
  Next j
  Application.ScreenUpdating = False
  With Sheets("summary")
    .UsedRange.EntireRow.Delete
    With .Range("B2:C2").Resize(d.Count)
      .Value = Application.Transpose(Array(d.Keys, d.Items))
      With .Columns(2)
        .TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False
        With .Offset(, 7) ' ### was .Offset(, 5)
          .FormulaR1C1 = "=RC[-4]-RC[-3]+RC[-2]+RC[-1]"
          .Value = .Value
        End With
        '.Resize(, 3).EntireColumn.Insert '### not needed
      End With
      .Columns(1).TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False
      With .Columns(0)
        .Cells(1).Value = 1
        .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
      End With
    End With
    With .Range("A1:J1")
      .Value = Array("item", "CODE", "BRAND", "TYPE", "MANUFACTURE", "STOCK", "SALES", "PUR", "RETURNS", "BALANCE")
       .Font.Bold = True
  .Interior.Color = RGB(166, 166, 166)
      .EntireColumn.AutoFit
    End With
    With .UsedRange
      .BorderAround xlContinuous
      .Borders(xlInsideVertical).LineStyle = xlContinuous
      .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
  End With
  Application.ScreenUpdating = True
End Sub

for more detailes

INVEN with single search v0 c.xlsm
	A	B	C	D	E	F
1	item	CODE	BRAND	TYPE	MANUFACTURE	QTY
2	1	AA-1	10W40 208L	Q8	EU	2222
3	2	AA-2	15W40 208L	CAS	SU	400
4	3	AA-3	5W30 208L	Q8	EU	800
5	4	AA-4	5W30 12x1L	Q8	EU	600
6	5	AA-5	10W40 208L	ENI	IT	300
7	6	AA-6	5W30 4x4L	Q8	EU	200
8	7	AA-7	10W40 12x1L	Q8	EU	120
9	8	AA-8	15W40 12x1L	CAS	SU	450
10	9	AA-9	10W40 12x1L	ENI	IT	890
11	10	AA-10	10W40 4x4L	Q8	EU	345
12	11	AA-11	10W40 4x4L	CAS	SU	78
13	12	AA-12	10W40 4x4L	ENI	IT	123
14	13	AA-13	5W40 4x4L	Q8	EU	456
15	14	AA-14	5W40 4x4L	CAS	SU	678
16	15	AA-15	5W40 4x4L	ENI	IT	1234
17	16	AA-16	20W50 4x4L	Q8	EU	456
stock

INVEN with single search v0 c.xlsm
	A	B	C	D	E	F
1	DATE	CODE	BRAND	TYPE	MANUFACTURE	SALES
2	1/1/2021	AA-1	10W40 208L	Q8	EU	100
3	1/2/2021	AA-2	15W40 208L	CAS	SU	50
4	1/3/2021	AA-3	5W30 208L	Q8	EU	280
5	1/4/2021	AA-4	5W30 12x1L	Q8	EU	300
6	1/5/2021	AA-5	10W40 208L	ENI	IT	80
7	1/6/2021	AA-6	5W30 4x4L	Q8	EU	20
8	1/7/2021	AA-7	10W40 12x1L	Q8	EU	20
9	1/8/2021	AA-8	15W40 12x1L	CAS	SU	20
10	1/9/2021	AA-9	10W40 12x1L	ENI	IT	876
11	1/10/2021	AA-10	10W40 4x4L	Q8	EU	345
12	1/11/2021	AA-11	10W40 4x4L	CAS	SU	123
13	1/12/2021	AA-12	10W40 4x4L	ENI	IT	78
14	1/13/2021	AA-13	5W40 4x4L	Q8	EU	300
15	1/14/2021	AA-14	5W40 4x4L	CAS	SU	34
16	1/15/2021	AA-15	5W40 4x4L	ENI	IT	23
17	1/16/2021	AA-16	20W50 4x4L	Q8	EU	56
18	1/17/2021	AA-1	10W40 208L	Q8	EU	100
sales

INVEN with single search v0 c.xlsm
	A	B	C	D	E	F
1	DATE	CODE	BRAND	TYPE	MANUFACTURE	PURCHASE
2	2/4/2021	AA-1	10W40 208L	Q8	EU	55
3	2/5/2021	AA-2	15W40 208L	CAS	SU	20
4	2/6/2021	AA-3	5W30 208L	Q8	EU	10
5	2/7/2021	AA-4	5W30 12x1L	Q8	EU	10
6	2/8/2021	AA-5	10W40 208L	ENI	IT	3
7	2/9/2021	AA-6	5W30 4x4L	Q8	EU	4
8	2/10/2021	AA-7	10W40 12x1L	Q8	EU	45
9	2/11/2021	AA-8	15W40 12x1L	CAS	SU	8
10	2/12/2021	AA-9	10W40 12x1L	ENI	IT	1
11	2/13/2021	AA-10	10W40 4x4L	Q8	EU	100
12	2/14/2021	AA-11	10W40 4x4L	CAS	SU	20
13	2/15/2021	AA-12	10W40 4x4L	ENI	IT	100
14	2/16/2021	AA-13	5W40 4x4L	Q8	EU	44
15	2/17/2021	AA-14	5W40 4x4L	CAS	SU	20
16	2/18/2021	AA-15	5W40 4x4L	ENI	IT	50
17	2/19/2021	AA-16	20W50 4x4L	Q8	EU	12
18	2/20/2021	AA-17	20W50 4x4L	CAS	SU	9
19	2/21/2021	AA-18	20W50 4x4L	ENI	IT	4
20	2/22/2021	AA-1	10W40 208L	Q8	EU	55
pur

INVEN with single search v0 c.xlsm
	A	B	C	D	E	F
1	item	CODE	BRAND	TYPE	MANUFACTURE	returns
2	4/5/2021	AA-9	10W40 12x1L	ENI	IT	20
3	4/6/2021	AA-10	10W40 4x4L	Q8	EU	30
4	4/7/2021	AA-11	10W40 4x4L	CAS	SU	40
5	4/8/2021	AA-4	5W30 12x1L	Q8	EU	10
6	4/9/2021	AA-4	5W30 12x1L	Q8	EU	11
returns

result

INVEN with single search v0 c.xlsm
	A	B	C	D	E	F	G	H	I	J
1	item	CODE	BRAND	TYPE	MANUFACTURE	STOCK	SALES	PUR	RETURNS	BALANCE
2	1	AA-1	10W40 208L	Q8	EU	2222	200	110		2132
3	2	AA-2	15W40 208L	CAS	SU	400	50	20		370
4	3	AA-3	5W30 208L	Q8	EU	800	280	10		530
5	4	AA-4	5W30 12x1L	Q8	EU	600	300	10	21	331
6	5	AA-5	10W40 208L	ENI	IT	300	80	3		223
7	6	AA-6	5W30 4x4L	Q8	EU	200	20	4		184
8	7	AA-7	10W40 12x1L	Q8	EU	120	20	45		145
9	8	AA-8	15W40 12x1L	CAS	SU	450	20	8		438
10	9	AA-9	10W40 12x1L	ENI	IT	890	876	1	20	35
11	10	AA-10	10W40 4x4L	Q8	EU	345	345	100	30	130
12	11	AA-11	10W40 4x4L	CAS	SU	78	123	20	40	15
13	12	AA-12	10W40 4x4L	ENI	IT	123	78	100		145
14	13	AA-13	5W40 4x4L	Q8	EU	456	300	44		200
15	14	AA-14	5W40 4x4L	CAS	SU	678	34	20		664
16	15	AA-15	5W40 4x4L	ENI	IT	1234	23	50		1261
17	16	AA-16	20W50 4x4L	Q8	EU	456	56	12		412
18	17	AA-17	20W50 4x4L	CAS	SU			9		9
19	18	AA-18	20W50 4x4L	ENI	IT			4		4
summary

can anybody make it fast,please?

 

[offthelip]

change this line:

s = .Cells(i, 2)

to

s=a(i,2)

Note this does assume your used range starts at cell A1, if it doesn't there are ways round it.

 

[leap out]

thanks for your suggestion, but unfortunately still too slow . it gives 42.40 sec when I test it .

 

[offthelip]

Your code has a lot of lines where you are splitting up the value of the dictionary to then add a number to the final part of the dictionary value and then joning it back up again. I don't think you need to do this. My idea is to make the dictionary key the concatenation of all of column B,C , D and E, the dictinalry vlaue is then just the count . Then it is very easy to add in the extra stock without splitting and joining. Like this:

  Set d = CreateObject("Scripting.Dictionary")
  ShList = Split("stock|sales|pur|returns", "|")
  For j = 0 To UBound(ShList)
    With Sheets(ShList(j))
      a = .UsedRange.Value2
      For i = 2 To UBound(a)
        s = a(i, 2) & a(i, 3) & a(i, 4) & a(i5)   ' contcatenate beforee adding to dictionary
        If Len(a(i, 2)) > 2 Then
         
          If Not d.exists(s) Then
            d.Add s, a(i, 6)
          Else
            d(s) = d(s) + a(i, 6)
          End If
        End If
      Next i
    End With
  Next j

 

[leap out]

thanks but the showing of data are incorrect
this is what I got

INVEN with single search v0 c.xlsm
	A	B	C	D	E	F	G	H	I	J
1	item	CODE	BRAND	TYPE	MANUFACTURE	STOCK	SALES	PUR	RETURNS	BALANCE
2	1	AA-110W40 208LQ8EU	2132							0
3	2	AA-215W40 208LCASSU	370							0
4	3	AA-35W30 208LQ8EU	530							0
5	4	AA-45W30 12x1LQ8EU	331							0
6	5	AA-510W40 208LENIIT	223							0
7	6	AA-65W30 4x4LQ8EU	184							0
8	7	AA-710W40 12x1LQ8EU	145							0
9	8	AA-815W40 12x1LCASSU	438							0
10	9	AA-910W40 12x1LENIIT	35							0
11	10	AA-1010W40 4x4LQ8EU	130							0
12	11	AA-1110W40 4x4LCASSU	15							0
13	12	AA-1210W40 4x4LENIIT	145							0
14	13	AA-135W40 4x4LQ8EU	200							0
15	14	AA-145W40 4x4LCASSU	664							0
16	15	AA-155W40 4x4LENIIT	1261							0
17	16	AA-1620W50 4x4LQ8EU	412							0
18	17	AA-1710W40 4x4LCASSU	9							0
19	18	AA-1810W40 4x4LENIIT	4							0
summary

 

[johnnyL]

@leap out, Because of your question, I have decided to try and learn how dictionaries work. I am familiar with arrays, but dictionaries are a bit different. Once I wrap my head around the idea, I will post back here, with hopefully a solution you can test.

 

[bebo021999]

Hope it works:

Option Explicit
Sub test()
Dim lr&, i&, k&, rng, arr(), ws, Val, id As String
Dim dic As Object, key
Set dic = CreateObject("Scripting.Dictionary")
ws = Array("stock", "sales", "pur", "returns")
For k = 1 To UBound(ws) + 1
    With Worksheets(ws(k - 1))
        lr = .Cells(Rows.Count, "B").End(xlUp).Row
        rng = .Range("A2:F" & lr).Value2
        For i = 1 To lr - 1
            id = rng(i, 2) & "|" & rng(i, 3) & "|" & rng(i, 4) & "|" & rng(i, 5)
            If Not dic.exists(id) Then
                Val = Array(0, 0, 0, 0)
                Val(k - 1) = rng(i, 6)
                dic.Add id, Val
            Else
                Val = dic(id)
                Val(k - 1) = Val(k - 1) + rng(i, 6)
                dic(id) = Val
            End If
        Next
    End With
Next
ReDim arr(1 To dic.Count, 1 To 10)
k = 0
For Each key In dic.keys
    k = k + 1: arr(k, 1) = k
    For i = 0 To 3
        arr(k, i + 2) = Split(key, "|")(i)
    Next
    For i = 0 To 3
        arr(k, i + 6) = dic(key)(i)
    Next
    arr(k, 10) = arr(k, 6) - arr(k, 7) + arr(k, 8) + arr(k, 9)
Next
With Worksheets("summary")
    .Range("A2:J10000").ClearContents
    .Range("A2").Resize(UBound(arr), 10).Value = arr
End With
End Sub

 

[johnnyL]

@leap out, Because of your question, I have decided to try and learn how dictionaries work. I am familiar with arrays, but dictionaries are a bit different. Once I wrap my head around the idea, I will post back here, with hopefully a solution you can test.

Here is what I came up with:

Sub CollateData_v5()
'
'   This requires creating a new class Module that you will name 'AF_DictionaryClass'
'
'       In that Class Module type the following:
'    Public ThisCode         As String       ' Code ... Key
'
'    Public ThisBrand        As String       ' Brand ... Item
'    Public ThisType         As String       ' Type ... Item
'    Public ThisManufacture  As String       ' Manufacture ... Item
'    Public ThisStock        As Long         ' stock ... Item
'    Public ThisSales        As Long         ' sales ... Item
'    Public ThisPur          As Long         ' pur ... Item
'    Public ThisReturns      As Long         ' returns ... Item
'
'       That will establish the key and 7 items for the key, make sure you Dim them properly. ;)
'
    Dim StartTime           As Double
    StartTime = Timer                                                                   ' Start the stopwatch
'
    Dim ArrayFreeDictionary As AF_DictionaryClass
    Dim ElapsedTime         As Double
    Dim ArrayRow            As Long
    Dim CodeColumn          As Long, BrandColumn        As Long, TypeColumn As Long
    Dim ManufactureColumn   As Long, QuantityColumn     As Long
    Dim StartRow            As Long, LastRow            As Long
    Dim SheetName           As Long
    Dim TheDictionary       As Object
    Dim ThisCode            As String
    Dim key                 As Variant
    Dim OutputArray         As Variant
    Dim SheetDataArray      As Variant, SheetNameArray  As Variant
    Dim OutputSheet         As Worksheet
'
    StartRow = 2                                                                        ' <--- Set this to the start row of input data and output data
    Set OutputSheet = Sheets("summary")                                                 ' <--- Set this to the sheet name that you display results to
'
    Set TheDictionary = CreateObject("scripting.dictionary")                            ' Create TheDictionary
'
    SheetNameArray = Array("stock", "sales", "pur", "returns")                          ' Add sheet names to SheetNameArray
'
           CodeColumn = 2
          BrandColumn = 3
           TypeColumn = 4
    ManufactureColumn = 5
       QuantityColumn = 6
'
    For SheetName = 0 To UBound(SheetNameArray)                                         ' Loop through sheets in SheetNameArray
        SheetDataArray = Sheets(SheetNameArray(SheetName)).UsedRange.Value2             '   Load data from sheet into SheetDataArray
'
        For ArrayRow = StartRow To UBound(SheetDataArray, 1)                            '   Loop through rows of each sheets data
            ThisCode = SheetDataArray(ArrayRow, CodeColumn)                             '       Save the 'code' into ThisCode
'
            If TheDictionary.Exists(ThisCode) Then                                      '       If the 'code' has already been added then ...
                Set ArrayFreeDictionary = TheDictionary(ThisCode)                       '
            Else                                                                        '       Else ...
                Set ArrayFreeDictionary = New AF_DictionaryClass                        '       Create a new AF_DictionaryClass object
'
                TheDictionary.Add ThisCode, ArrayFreeDictionary                         '       Add the 'code' & new AF_DictionaryClass object to
'                                                                                       '               the dictionary
            End If
'
                  ArrayFreeDictionary.ThisBrand = SheetDataArray(ArrayRow, BrandColumn) '       Add Brand to ArrayFreeDictionary.ThisBrand
                   ArrayFreeDictionary.ThisType = SheetDataArray(ArrayRow, TypeColumn)  '       Add Type to ArrayFreeDictionary.ThisType
            ArrayFreeDictionary.ThisManufacture = SheetDataArray(ArrayRow, ManufactureColumn)   '       Add Manufacture to ArrayFreeDictionary.ThisManufacture
'
            Select Case SheetName
                Case 0: ArrayFreeDictionary.ThisStock = SheetDataArray(ArrayRow, QuantityColumn) _
                        + ArrayFreeDictionary.ThisStock                                 '           Add quantity to ArrayFreeDictionary.ThisStock
                Case 1: ArrayFreeDictionary.ThisSales = SheetDataArray(ArrayRow, QuantityColumn) _
                        + ArrayFreeDictionary.ThisSales                                 '           Add quantity to ArrayFreeDictionary.ThisSales
                Case 2: ArrayFreeDictionary.ThisPur = SheetDataArray(ArrayRow, QuantityColumn) _
                        + ArrayFreeDictionary.ThisPur                                   '           Add quantity to ArrayFreeDictionary.ThisPur
                Case 3: ArrayFreeDictionary.ThisReturns = SheetDataArray(ArrayRow, QuantityColumn) _
                        + ArrayFreeDictionary.ThisReturns                               '           Add quantity to ArrayFreeDictionary.ThisReturns
            End Select
        Next                                                                            '   Loop back
    Next                                                                                ' Loop back
'
'----------------------------------------------------------
'
' Write the Dictionary contents to an array
'
    ReDim OutputArray(1 To TheDictionary.Count, 1 To 9)
'
    ArrayRow = 1                                                                        ' Initialize ArrayRow
'
    For Each key In TheDictionary.Keys                                                  ' Loop through keys in TheDictionary
        Set ArrayFreeDictionary = TheDictionary(key)
'
        With ArrayFreeDictionary
            OutputArray(ArrayRow, 1) = ArrayRow
            OutputArray(ArrayRow, 2) = key                                              '       Write the contents of TheDictionary to OutputArray
            OutputArray(ArrayRow, 3) = .ThisBrand
            OutputArray(ArrayRow, 4) = .ThisType
            OutputArray(ArrayRow, 5) = .ThisManufacture
            OutputArray(ArrayRow, 6) = .ThisStock
            OutputArray(ArrayRow, 7) = .ThisSales
            OutputArray(ArrayRow, 8) = .ThisPur
            OutputArray(ArrayRow, 9) = .ThisReturns
'
            ArrayRow = ArrayRow + 1                                                     '       Increment ArrayRow
        End With
    Next                                                                                ' Loop back
'
'----------------------------------------------------------
'
' Write the array to worksheet
    With OutputSheet
        .UsedRange.ClearContents                                                        '   Delete all existing data from the OutputSheet
'
        .Range("A2").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)) = OutputArray   '   Display OutputArray to OutputSheet
'
        With .Range("A1:J1")
            .Value = Array("item", "CODE", "BRAND", "TYPE", "MANUFACTURE", "STOCK", _
                    "SALES", "PUR", "RETURNS", "BALANCE")                               '       Display Headers to OutputSheet
            .Font.Bold = True                                                           '       Bold the Headers
            .Interior.Color = RGB(166, 166, 166)                                        '       Fill the cells of the Headers with a color
            .EntireColumn.AutoFit                                                       '       Size the columns to autofit
        End With
'
        LastRow = .Range("B" & Rows.Count).End(xlUp).row                                '   Get last used row in OutputSheet
'
        .UsedRange.NumberFormat = "0;-0;;@"                                             '   Format the cells of the OutputSheet to hide zero values
'
        With .Range("J2:J" & LastRow)
            .Value = OutputSheet.Evaluate(.Offset(0, -4).Address & "-" & _
                    .Offset(0, -3).Address & "+" & .Offset(0, -2).Address & _
                    "+" & .Offset(0, -1).Address)                                       '       Use formula to calculate 'Balance' column values
        End With
    End With
'
'----------------------------------------------------------
'
    ElapsedTime = Timer - StartTime                                                     ' Save ElapsedTime
    Debug.Print "Time to complete operation was " & ElapsedTime & " seconds."           ' Display elapsed time to 'Immediate' window (CTRL+G) in VBE
    MsgBox "Time to complete operation was " & ElapsedTime & " seconds."                ' Display elapsed time to message box
End Sub

 

[JEC]

To keep everything within the dictionary. Should be very fast

Sub jec()
 Dim sp, ar, k, a, j As Long, jj As Long, x As Long
 sp = Split("stock|sales|pur|returns", "|")
  
 With CreateObject("scripting.dictionary")
    For j = 0 To UBound(sp)
       ar = Sheets(sp(j)).UsedRange
       For jj = 2 To UBound(ar)
         k = ar(jj, 3) & "|" & ar(jj, 4) & "|" & ar(jj, 5)
         If Not .exists(k) Then
           .Item(k) = Array(x + 1, ar(jj, 2), ar(jj, 3), ar(jj, 4), ar(jj, 5), 0, 0, 0, 0, 0)
           a = .Item(k)
           a(j + 5) = ar(jj, 6)
           a(9) = ar(jj, 6)
           x = x + 1
         Else
           a = .Item(k)
           a(j + 5) = a(j + 5) + ar(jj, 6)
           a(9) = a(9) + IIf(j = 1, -ar(jj, 6), ar(jj, 6))
         End If
         .Item(k) = a
       Next
    Next
    Sheets("summary").Range("A2").Resize(.Count, 10) = Application.Index(.items, 0, 0)
 End With
End Sub

 

[JEC]

Could not change it anymore, here a version with one less variable

Sub jec()
 Dim sp, ar, k, a, j As Long, jj As Long
 sp = Split("stock|sales|pur|returns", "|")
 
 With CreateObject("scripting.dictionary")
    For j = 0 To UBound(sp)
       ar = Sheets(sp(j)).UsedRange
       For jj = 2 To UBound(ar)
         k = ar(jj, 3) & "|" & ar(jj, 4) & "|" & ar(jj, 5)
         If Not .exists(k) Then
           .Item(k) = Array(.Count + 1, ar(jj, 2), ar(jj, 3), ar(jj, 4), ar(jj, 5), 0, 0, 0, 0, 0)
           a = .Item(k)
           a(j + 5) = ar(jj, 6)
           a(9) = ar(jj, 6)
         Else
           a = .Item(k)
           a(j + 5) = a(j + 5) + ar(jj, 6)
           a(9) = a(9) + IIf(j = 1, -ar(jj, 6), ar(jj, 6))
         End If
         .Item(k) = a
       Next
    Next
    Sheets("summary").Range("A2").Resize(.Count, 10) = Application.Index(.items, 0, 0)
 End With
End Sub