Extract data based on matching headers with sheets names across sheets

[Ali M]

Hi
I want macro to create report in REPORT sheet
I want merge amounts in TOTAL column for duplicates names based on NAME column for each sheet alone .
when matching headers C:F in report sheet with sheets names then will brings the names and merge amount for each sheet .
as to columns DEBIT,CREDIT will brings & merge from VOUCHER sheet
I want create the same formatting and formulas (no need showing formulas , just to understand how calculate )as I did it in REPORT sheet.
every time running macro should delete data from row2 before create report
the data could be 7000 rows for each sheet.

Permit.xlsm
	A	B	C	D	E	F
1	DATE	NAME	BATCH	QTY	PRICE	TOTAL
2	01/01/2023	ALI	XCDF100	200.000	20.000	4,000.000
3	01/01/2023	ALI	XCDF101	10.000	20.000	200.000
4	02/01/2023	OMAR	XCDF102	20.000	22.000	440.000
5	02/01/2023	OMAR	XCDF101	10.000	30.000	300.000
6	02/01/2023	OMAR	XCDF100	10.000	50.000	500.000
7	02/01/2023	OMAR	XCDF103	20.000	20.000	400.000
8	02/01/2023	AMER	XCDF104	10.000	10.000	100.000
9	03/01/2023	AMER	XCDF105	10.000	10.000	100.000
10	04/01/2023	AMER	XCDF106	10.000	10.000	100.000
11	05/01/2023	AMUR	XCDF107	10.000	10.000	100.000
MTR

Cell Formulas
Range	Formula
F2:F11	F2	=D2*E2

Permit.xlsm
	A	B	C	D	E	F
1	DATE	NAME	BATCH	QTY	PRICE	TOTAL
2	01/01/2023	OMRAAN	XCDF100	200.000	22.000	4,400.000
3	01/01/2023	OMRAAN	XCDF101	10.000	24.000	240.000
4	02/01/2023	OMRAAN	XCDF102	20.000	25.000	500.000
5	02/01/2023	OMRAAN	XCDF103	10.000	26.000	260.000
6	02/01/2023	OMRAAN	XCDF104	10.000	24.000	240.000
7	02/01/2023	ALI	XCDF104	10.000	29.000	290.000
VSTR

Cell Formulas
Range	Formula
F2:F7	F2	=D2*E2

Permit.xlsm
	A	B	C	D	E	F
1	DATE	NAME	BATCH	QTY	PRICE	TOTAL
2	01/01/2023	ALI	XCDF100	10.000	20.000	200.000
3	01/01/2023	ALI	XCDF101	2.000	20.000	40.000
4	02/01/2023	ALI	XCDF102	2.000	22.000	44.000
5	02/01/2023	ALI	XCDF101	2.000	30.000	60.000
6	02/01/2023	HASSON	XCDF100	2.000	50.000	100.000
7	02/01/2023	HASSON	XCDF103	2.000	20.000	40.000
8	02/01/2023	ALI	XCDF104	2.000	10.000	20.000
9	04/01/2023	AMER	XCDF106	2.000	10.000	20.000
VDRT

Cell Formulas
Range	Formula
F2:F9	F2	=D2*E2

Permit.xlsm
	A	B	C	D	E	F
1	DATE	NAME	BATCH	QTY	PRICE	TOTAL
2	01/01/2023	OMRAAN	XCDF100	1.000	22.000	22.000
3	01/01/2023	OMRAAN	XCDF101	1.000	24.000	24.000
4	02/01/2023	HASSON	XCDF102	20.000	25.000	500.000
5	02/01/2023	OMRAAN	XCDF103	10.000	26.000	260.000
6	02/01/2023	OMRAAN	XCDF104	10.000	24.000	240.000
7	02/01/2023	ALI	XCDF104	10.000	29.000	290.000
FGRT

Cell Formulas
Range	Formula
F2:F7	F2	=D2*E2

Permit.xlsm
	A	B	C	D	E
1	DATE	NAME	VOUCHER NO	DEBIT	CREDIT
2	12/02/2024	ALI	VBNY66	2,000.00
3	13/02/2024	ALI	VBNY67	10,000.00
4	13/02/2024	ALI	PPDFG100		2,000.00
5	13/02/2024	HASSON	VBNY68	2,000.00
6	14/02/2024	HASSON	VBNY69	1,500.00
7	13/02/2024	ALI	PPDFG101		2,000.00
VOUCHER

before

Permit.xlsm
	A	B	C	D	E	F	G	H	I
1	ITEM	NAME	MTR	VSTR	VDRT	FGRT	DEBIT	CREDIT	BALANCE
REPORT

result

Permit.xlsm
	A	B	C	D	E	F	G	H	I
1	ITEM	NAME	MTR	VSTR	VDRT	FGRT	DEBIT	CREDIT	BALANCE
2	1	ALI	4,200.00	290.00	364.00	290.00	12,000.00	4,000.00	11,984.00
3	2	AMUR	100.00	-	0.00	-	-	-	100.00
4	3	AMER	300.00	-	20.00	-	-	-	320.00
5	4	HASSON	-	-	140.00	500.00	3,500.00	-	3,140.00
6	5	OMAR	1,640.00	-	-	-	-	-	1,640.00
7	6	OMRAAN	-	5,640.00	-	546.00	-	-	-6,186.00
8	TOTAL		6,240.00	5,930.00	524.00	1,336.00	15,500.00	4,000.00	10,998.00
REPORT

Cell Formulas
Range	Formula
I2:I8	I2	=C2-D2+E2-F2+G2-H2
C8:H8	C8	=SUM(C2:C7)

I hope somebody help.

 

[DanteAmor]

Try this:

Sub Extract_Data()
  Dim shR As Worksheet, sh As Worksheet
  Dim arrSH As Variant, mysh As Variant, a() As Variant, b As Variant
  Dim i As Long, j As Long, lr As Long, y As Long, n As Long
  Dim dic As Object
  
  Application.ScreenUpdating = False
  
  'Name of sheets to merge
  arrSH = Array("MTR", "VSTR", "VDRT", "FGRT", "VOUCHER")
  
  'Output sheet name
  Set shR = Sheets("Report")
  n = UBound(arrSH)
  shR.Range("A2", shR.Cells(Rows.Count, 5 + n)).Clear
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  For Each mysh In arrSH
    Set sh = Sheets(mysh)
    Erase a
    a = sh.Range("A2:F" & sh.Range("B" & Rows.Count).End(3).Row).Value
    
    For i = 1 To UBound(a, 1)
      If Not dic.exists(a(i, 2)) Then
        y = y + 1
        dic(a(i, 2)) = y
      End If
    Next
  Next
  
  ReDim b(1 To y + 1, 1 To 9)
  
  j = 3
  For Each mysh In arrSH
    Set sh = Sheets(mysh)
    Erase a
    a = sh.Range("A2:F" & sh.Range("B" & Rows.Count).End(3).Row).Value
    
    For i = 1 To UBound(a, 1)
      y = dic(a(i, 2))
      b(y, 2) = a(i, 2)
      
      If j < 3 + n Then
        b(y, j) = b(y, j) + a(i, 6)
      Else
        b(y, j) = b(y, j) + a(i, 4)
        b(y, j + 1) = b(y, j + 1) + a(i, 5)
      End If
    Next
    j = j + 1
  Next
   
  shR.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  lr = shR.Range("B" & Rows.Count).End(3).Row
  shR.Range("A2", shR.Cells(lr, 5 + n)).Sort shR.Range("B1"), xlAscending, Header:=xlYes
  With shR.Range("C2", shR.Cells(lr + 1, 5 + n))
    .SpecialCells(xlCellTypeBlanks).Value = 0
    .NumberFormat = "#,##0.00;-#,##0.00;-"
  End With
  With shR.Range("A1", shR.Cells(1, 5 + n)).EntireColumn
    .HorizontalAlignment = xlCenter
    .ColumnWidth = 13
  End With
  shR.Range("A2").Value = 1
  shR.Range("A2:A" & lr).DataSeries xlColumns, xlLinear, xlDay, 1, Trend:=False
  With shR.Range("A" & lr + 1)
    .Value = "TOTAL"
    .Interior.Color = 11184814
    .Font.Bold = True
  End With
  With shR.Range(shR.Cells(2, 5 + n), shR.Cells(lr, 5 + n))
    .Formula = "=C2-D2+E2-F2+G2-H2"
    .Value = .Value
  End With
  With shR.Range("C" & lr + 1).Resize(1, 3 + n)
    .Formula = "=SUM(C2:C" & lr & ")"
    .Value = .Value
  End With
  Application.ScreenUpdating = True
End Sub

 

[Ali M]

Awesome !
can fill borders around the cells , please?

 

[DanteAmor]

Awesome !
can fill borders around the cells , please?

Try:

Sub Extract_Data()
  Dim shR As Worksheet, sh As Worksheet
  Dim arrSH As Variant, mysh As Variant, a() As Variant, b As Variant
  Dim i As Long, j As Long, lr As Long, y As Long, n As Long
  Dim dic As Object
  
  Application.ScreenUpdating = False
  
  'Name of sheets to merge
  arrSH = Array("MTR", "VSTR", "VDRT", "FGRT", "VOUCHER")
  
  'Output sheet name
  Set shR = Sheets("Report")
  n = UBound(arrSH)
  shR.Range("A2", shR.Cells(Rows.Count, 5 + n)).Clear
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  For Each mysh In arrSH
    Set sh = Sheets(mysh)
    Erase a
    a = sh.Range("A2:F" & sh.Range("B" & Rows.Count).End(3).Row).Value
    
    For i = 1 To UBound(a, 1)
      If Not dic.exists(a(i, 2)) Then
        y = y + 1
        dic(a(i, 2)) = y
      End If
    Next
  Next
  
  ReDim b(1 To y + 1, 1 To 9)
  
  j = 3
  For Each mysh In arrSH
    Set sh = Sheets(mysh)
    Erase a
    a = sh.Range("A2:F" & sh.Range("B" & Rows.Count).End(3).Row).Value
    
    For i = 1 To UBound(a, 1)
      y = dic(a(i, 2))
      b(y, 2) = a(i, 2)
      
      If j < 3 + n Then
        b(y, j) = b(y, j) + a(i, 6)
      Else
        b(y, j) = b(y, j) + a(i, 4)
        b(y, j + 1) = b(y, j + 1) + a(i, 5)
      End If
    Next
    j = j + 1
  Next
   
  shR.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  lr = shR.Range("B" & Rows.Count).End(3).Row
  shR.Range("A2", shR.Cells(lr, 5 + n)).Sort shR.Range("B1"), xlAscending, Header:=xlYes
  With shR.Range("C2", shR.Cells(lr + 1, 5 + n))
    .SpecialCells(xlCellTypeBlanks).Value = 0
    .NumberFormat = "#,##0.00;-#,##0.00;-"
  End With
  With shR.Range("A1", shR.Cells(1, 5 + n)).EntireColumn
    .HorizontalAlignment = xlCenter
    .ColumnWidth = 13
  End With
  shR.Range("A2").Value = 1
  shR.Range("A2:A" & lr).DataSeries xlColumns, xlLinear, xlDay, 1, Trend:=False
  With shR.Range("A" & lr + 1)
    .Value = "TOTAL"
    .Interior.Color = 11184814
    .Font.Bold = True
  End With
  With shR.Range(shR.Cells(2, 5 + n), shR.Cells(lr, 5 + n))
    .Formula = "=C2-D2+E2-F2+G2-H2"
    .Value = .Value
  End With
  With shR.Range("C" & lr + 1).Resize(1, 3 + n)
    .Formula = "=SUM(C2:C" & lr & ")"
    .Value = .Value
  End With
  shR.Range("A1", shR.Cells(lr + 1, 5 + n)).Borders.LineStyle = xlContinuous
  Application.ScreenUpdating = True
End Sub

 

[Ali M]

excellent !
many thanks for your help.