copy multiple columns and matched from multiple sheets to sheet summary and calculate

[leap out]

hi experts,
I know what I'm asking is not easy but i hope to see my post by any has knowing in vba so I have multiple sheets are the same structure should match COL B,C,D with all sheets in all sheets then should create the all of data in sheet summary and calculate the values
I put the formula how should calculate the values and sorry if my data are poor , just tell me if that's not clear
sheet "stock"

REPORT1.xlsx
	A	B	C	D	E
1	item	BRAND	TYPE	MONAFACTURE	QTY
2	1	10W40 208L	Q8	EU	1000
3	2	15W40 208L	CAS	SU	400
4	3	5W30 208L	Q8	EU	800
5	4	5W30 12x1L	Q8	EU	600
6	5	10W40 208L	ENI	IT	300
7	6	5W30 4x4L	Q8	EU	200
8	7	10W40 12x1L	Q8	EU	120
9	8	15W40 12x1L	CAS	SU	450
10	9	10W40 12x1L	ENI	IT	890
11	10	10W40 4x4L	Q8	EU	345
12	11	10W40 4x4L	CAS	SU	78
13	12	10W40 4x4L	ENI	IT	123
14	13	5W40 4x4L	Q8	EU	456
15	14	5W40 4x4L	CAS	SU	678
16	15	5W40 4x4L	ENI	IT	1234
17	16	20W50 4x4L	Q8	EU	456
stock

sheet sales

REPORT1.xlsx
	A	B	C	D	E
1	item	BRAND	TYPE	MONAFACTURE	SALES
2	1	10W40 208L	Q8	EU	100
3	2	15W40 208L	CAS	SU	50
4	3	5W30 208L	Q8	EU	280
5	4	5W30 12x1L	Q8	EU	300
6	5	10W40 208L	ENI	IT	80
7	6	5W30 4x4L	Q8	EU	20
8	7	10W40 12x1L	Q8	EU	20
9	8	15W40 12x1L	CAS	SU	20
10	9	10W40 12x1L	ENI	IT	876
11	10	10W40 4x4L	Q8	EU	345
12	11	10W40 4x4L	CAS	SU	123
13	12	10W40 4x4L	ENI	IT	78
14	13	5W40 4x4L	Q8	EU	300
15	14	5W40 4x4L	CAS	SU	34
16	15	5W40 4x4L	ENI	IT	23
17	16	20W50 4x4L	Q8	EU	56
sales

sheets "pur "

REPORT1.xlsx
	A	B	C	D	E
1	item	BRAND	TYPE	MONAFACTURE	PURCHASE
2	1	10W40 208L	Q8	EU	55
3	2	15W40 208L	CAS	SU	20
4	3	5W30 208L	Q8	EU	10
5	4	5W30 12x1L	Q8	EU	10
6	5	10W40 208L	ENI	IT	3
7	6	5W30 4x4L	Q8	EU	4
8	7	10W40 12x1L	Q8	EU	45
9	8	15W40 12x1L	CAS	SU	8
10	9	10W40 12x1L	ENI	IT	1
11	10	10W40 4x4L	Q8	EU	100
12	11	10W40 4x4L	CAS	SU	20
13	12	10W40 4x4L	ENI	IT	100
14	13	5W40 4x4L	Q8	EU	44
15	14	5W40 4x4L	CAS	SU	20
16	15	5W40 4x4L	ENI	IT	50
17	16	20W50 4x4L	Q8	EU	12
18	17	20W50 4x4L	CAS	SU	9
19	18	20W50 4x4L	ENI	IT	4
pur

sheet returns

REPORT1.xlsx
	A	B	C	D	E
1	item	BRAND	TYPE	MONAFACTURE	returns
2	1	10W40 12x1L	ENI	IT	20
3	2	10W40 4x4L	Q8	EU	30
4	3	10W40 4x4L	CAS	SU	40
5	4	5W30 12x1L	Q8	EU	10
returns

expected result in sheet "summary"

REPORT1.xlsx
	A	B	C	D	E	F	G	H	I
1	item	BRAND	TYPE	MONAFACTURE	STOCK	SALES	PUR	RETURNS	BALANCE
2	1	10W40 208L	Q8	EU	1000	100	55		955
3	2	15W40 208L	CAS	SU	400	50	20		370
4	3	5W30 208L	Q8	EU	800	280	10		530
5	4	5W30 12x1L	Q8	EU	600	300	10	10	320
6	5	10W40 208L	ENI	IT	300	80	3		223
7	6	5W30 4x4L	Q8	EU	200	20	4		184
8	7	10W40 12x1L	Q8	EU	120	20	45		145
9	8	15W40 12x1L	CAS	SU	450	20	8		438
10	9	10W40 12x1L	ENI	IT	890	876	1	20	35
11	10	10W40 4x4L	Q8	EU	345	345	100	30	130
12	11	10W40 4x4L	CAS	SU	78	123	20	40	15
13	12	10W40 4x4L	ENI	IT	123	78	100		145
14	13	5W40 4x4L	Q8	EU	456	300	44		200
15	14	5W40 4x4L	CAS	SU	678	34	20		664
16	15	5W40 4x4L	ENI	IT	1234	23	50		1261
17	16	20W50 4x4L	Q8	EU	456	56	12		412
18	17	20W50 4x4L	CAS	SU			9		9
19	18	20W50 4x4L	ENI	IT			4		4
20
summary

Cell Formulas
Range	Formula
I2:I19	I2	=E2-F2+G2+H2

 

[Marc L]

Hi,​

​

why in the returns worksheet the items have not the same item # according to previous worksheets ?​

​

​

 

[Peter_SSs]

Assuming all 5 sheets already exists but there is nothing in 'summary' sheet, try this with a copy of your workbook.
If there is already data in 'summary' what should happen when this code is run?
- new data appended to bottom of existing data, or
- existing data cleared before new data is entered, or
- something else

Sub CollateData()
  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 = Join(Application.Index(a, i, Array(2, 3, 4)), ";")
        If Not d.exists(s) Then d(s) = ";;;"
        vals = Split(d(s), ";")
        vals(j) = a(i, 5)
        d(s) = Join(vals, ";")
      Next i
    End With
  Next j
  Application.ScreenUpdating = False
  With Sheets("summary")
    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
        .Offset(, 4).FormulaR1C1 = "=RC[-4]-RC[-3]+RC[-2]+RC[-1]"
        .Resize(, 2).EntireColumn.Insert
      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:I1")
      .Value = Array("item", "BRAND", "TYPE", "MONAFACTURE", "STOCK", "SALES", "PUR", "RETURNS", "BALANCE")
      .EntireColumn.AutoFit
    End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[leap out]

@Peter_SSs great code! thanks
but show empty data in row 18 and it doesn't show the borders in last row as the rest rows I no know why and I would hide the formula in last column in BALANCE just show as value if that's possible
about this

- existing data cleared before new data is entered

yes should be

REPORT1.xlsx
	A	B	C	D	E	F	G	H	I	J	K
1	item	BRAND	TYPE	MONAFACTURE	STOCK	SALES	PUR	RETURNS	BALANCE
2	1	10W40 208L	Q8	EU	1000	100	55		955
3	2	15W40 208L	CAS	SU	400	50	20		370
4	3	5W30 208L	Q8	EU	800	280	10		530
5	4	5W30 12x1L	Q8	EU	600	300	10	10	320
6	5	10W40 208L	ENI	IT	300	80	3		223
7	6	5W30 4x4L	Q8	EU	200	20	4		184
8	7	10W40 12x1L	Q8	EU	120	20	45		145
9	8	15W40 12x1L	CAS	SU	450	20	8		438
10	9	10W40 12x1L	ENI	IT	890	876	1	20	35
11	10	10W40 4x4L	Q8	EU	345	345	100	30	130
12	11	10W40 4x4L	CAS	SU	78	123	20	40	15
13	12	10W40 4x4L	ENI	IT	123	78	100		145
14	13	5W40 4x4L	Q8	EU	456	300	44		200
15	14	5W40 4x4L	CAS	SU	678	34	20		664
16	15	5W40 4x4L	ENI	IT	1234	23	50		1261
17	16	20W50 4x4L	Q8	EU	456	56	12		412
18	17								0
19	18	20W50 4x4L	CAS	SU			9		9
20	19	20W50 4x4L	ENI	IT			4		4
summary

Cell Formulas
Range	Formula
I2:I20	I2	=E2-F2+G2+H2

 

[Peter_SSs]

show empty data in row 18

One or more of your input sheets must have one or more blank rows within the data. This possibility wasn't shown in your sample data.

doesn't show the borders in last row

Sorry, didn't realise that borders were part of what you were asking

hide the formula in last column in BALANCE just show as value

No problem

yes should be

No problem.

See if this takes care of the above issues.

Sub CollateData_v2()
  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 = Join(Application.Index(a, i, Array(2, 3, 4)), ";")
        If Len(s) > 2 Then
          If Not d.exists(s) Then d(s) = ";;;"
          vals = Split(d(s), ";")
          vals(j) = a(i, 5)
          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(, 4)
          .FormulaR1C1 = "=RC[-4]-RC[-3]+RC[-2]+RC[-1]"
          .Value = .Value
        End With
        .Resize(, 2).EntireColumn.Insert
      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:I1")
      .Value = Array("item", "BRAND", "TYPE", "MONAFACTURE", "STOCK", "SALES", "PUR", "RETURNS", "BALANCE")
      .EntireColumn.AutoFit
    End With
    With .UsedRange
      .BorderAround LineStyle:=xlContinuous
      .Borders(xlInsideVertical).LineStyle = xlContinuous
      .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[leap out]

very excellent !
ok just I want bold the word of the headers and highlight the interior color by grey
thanks again

 

[Peter_SSs]

bold the word of the headers and highlight the interior color by grey

Add these two blue lines where shown

With .Range("A1:I1")
  .Value = Array("item", "BRAND", "TYPE", "MONAFACTURE", "STOCK", "SALES", "PUR", "RETURNS", "BALANCE")
  .Font.Bold = True
  .Interior.Color = RGB(166, 166, 166)
  .EntireColumn.AutoFit
End With

 

[leap out]

thanks very much for your solution

 

[Peter_SSs]

You are very welcome.