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]

thanks but the showing of data are incorrect

Sorry about that I misunderstood your code, however I think the idea of trying to avoid joining and splitting up the dictionary item might be worth trying. I needed to do a similar thing with some code I wrote a little while ago, instead of joining and splitting I passed an array to the dictionary. I think this method would be very suitable for you and possibly a lot faster. This is my code:

Sub dictionaryandarray()
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim temparr() As Variant
Dim outarr()
With Worksheets("BOM")
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row   ' find last row of data
inarr = .Range(.Cells(1, 1), .Cells(LastRow, 7))     ' load the whole sheet of data into variant array ( 7 columns)
' find maximum week no
cwmax = 0
 For i = 4 To LastRow
   If inarr(i, 7) > cwmax Then
    cwmax = inarr(i, 7)
   End If
 Next i
'ReDim temparr(1 To 7)  ' to pass values to dictionary

 For i = 4 To LastRow
   If dict.Exists(inarr(i, 2)) Then
     Erase temparr
     ReDim temparr(1 To cwmax)  ' to pass values to dictionary
     temparr = dict.Item(inarr(i, 2)) ' load dictionary item into temp array
     temparr((inarr(i, 7))) = temparr(inarr(i, 7)) + inarr(i, 5)  ' add cost to total using week no as index
     dict.Item(inarr(i, 2)) = temparr  ' write tempory array back to dictionary
   Else
     Erase temparr
     ReDim temparr(1 To cwmax)  ' to pass values to dictionary
     temparr(inarr(i, 7)) = inarr(i, 5)   ' add first cost into total using week no as index
     dict.Add inarr(i, 2), temparr()
    End If
 Next i
End With
' output dictinary vlaues
 ReDim outarr(1 To LastRow, 1 To 5 + cwmax) '' define output array as the maximu possible size
indi = 1
For Each Key In dict
     Erase temparr
     ReDim temparr(1 To cwmax)  ' to pass values to dictionary
      temparr = dict.Item(Key)
     For j = 1 To cwmax
       outarr(indi, 4 + j) = temparr(j)
     Next j
     outarr(indi, 1) = Key
     indi = indi + 1
Next Key
With Worksheets("Sheet3")
.Range(.Cells(4, 2), .Cells(4 + indi, 5 + cwmax)) = outarr
End With
End Sub

 

[johnnyL]

Ok, my time test results are in for the following code submissions:

1.56875 average seconds for jecV2 post #10 with the output sheet cleared & 18K rows

1.03046875 average seconds for bebo021999 post #7 with zeros hidden & 18K rows

0.58984375 average seconds for johnnyL post #8 with 18k rows

 

[johnnyL]

Theoretically, that means the code from post #8 should be about 5 times faster than the code from the original post. Hopefully @leap out can confirm or deny with the real world testing, my testing results.

 

[leap out]

@bebo021999 awesome much appreciated your code
thanks very much

 

[leap out]

@JEC great ! but your code doesn't show the minus or positive value correctly . if there is just value in column sales then should show minus value when calculate in column BALANCE also if there is just value in column RETURNS then should show minus value in column BALANCE .
thanks

 

[leap out]

@johnnyL thanks but I can't test your code .it gives error as in picture .I thought script runtime doesn't select from reference ,but it seems another option should select, can you guide me to test it,please ? to select the most best solution

 

[leap out]

@offthelip thanks but I can't test your code . it askes me define some variable (LastRow ,inarr )

 

[johnnyL]

@johnnyL thanks but I can't test your code .it gives error as in picture .I thought script runtime doesn't select from reference ,but it seems another option should select, can you guide me to test it,please ? to select the most best solution

View attachment 70891

Did you follow the directions at the top of the script? Adding a class Module?

 

[johnnyL]

Here is a link to the file with the added class module I mentioned: here <---.

 

[leap out]

Did you follow the directions at the top of the script? Adding a class Module?

ok I create it and rename it but gives another error