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?

 

[johnnyL]

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

When you download that, you should be set to run the code. You can replace the data on the sheets and it should still work.

 

[leap out]

@johnnyL thanks for your code ,file and forgive me I don't used to calss module I thought just add in standard module without see you comment inside the code .
sorry I said that your code gives 16.5 sec then I see Jec's code is better gives 1.5sec for 18000 rows but not completely becuase doesn't show minus values .as to bebo021999's code gives 1,6 sec for 18000 rows
so I select bebo021999's code
thanks guys for all of theses assistance

 

[johnnyL]

Oki doki, You can lead 'em to water, but you can't make 'em drink. ;(

 

[JEC]

Ok how about:

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) = IIf(j = 1, -ar(jj, 6), 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

 

[leap out]

@JEC thanks for new version .
the column sales works and show the minus values, but the column RETURNS still doesn't show minus values

 

[JEC]

I don't see how. I have exactly the same output as Bebo's code

 

[leap out]

@JEC yes you're right about column returns . I don't note it about Bebo's code. how can I modify your code to show the minus values as columns sales to complete the project,please?

 

[JEC]

Could you post some sample data again with desired results? I can look tomorrow probably

 

[leap out]

OK
see the item for last row for sheets sales & returns
somtimes just I have item in sheet SALES but is not existed in others sheets ,also just I have item in sheet RETURNS but is not existed in others sheets . so when calculate the sheet sales for item AA-222= 0-101+0+0 the result is by minus -101 in column BALANCE for sheet SUMMARY .
as to sheet returns for ITEM AA-51=0-0+0-12 the result is by minus -12 in column BALANCE for sheet SUMMARY

INVEN.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
19	1/18/2021	AA-222	10W40 208L	Q9	EU	101
sales

INVEN.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
7	4/10/2021	AA-51	5W30 12x1L	Q9	EU	12
returns

result

INVEN.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	0	2132
3	2	AA-2	15W40 208L	CAS	SU	400	50	20	0	370
4	3	AA-3	5W30 208L	Q8	EU	800	280	10	0	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	0	223
7	6	AA-6	5W30 4x4L	Q8	EU	200	20	4	0	184
8	7	AA-7	10W40 12x1L	Q8	EU	120	20	45	0	145
9	8	AA-8	15W40 12x1L	CAS	SU	450	20	8	0	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	0	145
14	13	AA-13	5W40 4x4L	Q8	EU	456	300	44	0	200
15	14	AA-14	5W40 4x4L	CAS	SU	678	34	20	0	664
16	15	AA-15	5W40 4x4L	ENI	IT	1234	23	50	0	1261
17	16	AA-16	20W50 4x4L	Q8	EU	456	56	12	0	412
18	17	AA-222	10W40 208L	Q9	EU	0	101	0	0	-101
19	18	AA-17	20W50 4x4L	CAS	SU	0	0	9	0	9
20	19	AA-18	20W50 4x4L	ENI	IT	0	0	4	0	4
21	20	AA-51	5W30 12x1L	Q9	EU	0	0	0	12	-12
summary

I hope this help you

 

[JEC]

Ok give this a try:

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) = IIf(j = 1 Or j = 3, -ar(jj, 6), 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), IIf(j = 3 And a(5) & a(6) & a(7) = "000", -ar(jj, 6), ar(jj, 6)))
         End If
         .Item(k) = a
       Next
    Next
    Sheets("summary").Range("L2").Resize(.Count, 10) = Application.Index(.items, 0, 0)
 End With
End Sub