Extract data based on matching headers with sheets names across sheets

A

Ali M

Active Member
Joined
Oct 10, 2021
Messages
348
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
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
ABCDEF
1DATENAMEBATCHQTYPRICETOTAL
201/01/2023ALIXCDF100200.00020.0004,000.000
301/01/2023ALIXCDF10110.00020.000200.000
402/01/2023OMARXCDF10220.00022.000440.000
502/01/2023OMARXCDF10110.00030.000300.000
602/01/2023OMARXCDF10010.00050.000500.000
702/01/2023OMARXCDF10320.00020.000400.000
802/01/2023AMERXCDF10410.00010.000100.000
903/01/2023AMERXCDF10510.00010.000100.000
1004/01/2023AMERXCDF10610.00010.000100.000
1105/01/2023AMURXCDF10710.00010.000100.000
MTR
Cell Formulas
RangeFormula
F2:F11F2=D2*E2




Permit.xlsm
ABCDEF
1DATENAMEBATCHQTYPRICETOTAL
201/01/2023OMRAANXCDF100200.00022.0004,400.000
301/01/2023OMRAANXCDF10110.00024.000240.000
402/01/2023OMRAANXCDF10220.00025.000500.000
502/01/2023OMRAANXCDF10310.00026.000260.000
602/01/2023OMRAANXCDF10410.00024.000240.000
702/01/2023ALIXCDF10410.00029.000290.000
VSTR
Cell Formulas
RangeFormula
F2:F7F2=D2*E2


Permit.xlsm
ABCDEF
1DATENAMEBATCHQTYPRICETOTAL
201/01/2023ALIXCDF10010.00020.000200.000
301/01/2023ALIXCDF1012.00020.00040.000
402/01/2023ALIXCDF1022.00022.00044.000
502/01/2023ALIXCDF1012.00030.00060.000
602/01/2023HASSONXCDF1002.00050.000100.000
702/01/2023HASSONXCDF1032.00020.00040.000
802/01/2023ALIXCDF1042.00010.00020.000
904/01/2023AMERXCDF1062.00010.00020.000
VDRT
Cell Formulas
RangeFormula
F2:F9F2=D2*E2




Permit.xlsm
ABCDEF
1DATENAMEBATCHQTYPRICETOTAL
201/01/2023OMRAANXCDF1001.00022.00022.000
301/01/2023OMRAANXCDF1011.00024.00024.000
402/01/2023HASSONXCDF10220.00025.000500.000
502/01/2023OMRAANXCDF10310.00026.000260.000
602/01/2023OMRAANXCDF10410.00024.000240.000
702/01/2023ALIXCDF10410.00029.000290.000
FGRT
Cell Formulas
RangeFormula
F2:F7F2=D2*E2



Permit.xlsm
ABCDE
1DATENAMEVOUCHER NODEBITCREDIT
212/02/2024ALIVBNY662,000.00
313/02/2024ALIVBNY6710,000.00
413/02/2024ALIPPDFG1002,000.00
513/02/2024HASSONVBNY682,000.00
614/02/2024HASSONVBNY691,500.00
713/02/2024ALIPPDFG1012,000.00
VOUCHER




before
Permit.xlsm
ABCDEFGHI
1ITEMNAMEMTRVSTRVDRTFGRTDEBITCREDITBALANCE
REPORT



result

Permit.xlsm
ABCDEFGHI
1ITEMNAMEMTRVSTRVDRTFGRTDEBITCREDITBALANCE
21ALI4,200.00290.00364.00290.0012,000.004,000.0011,984.00
32AMUR100.00-0.00---100.00
43AMER300.00-20.00---320.00
54HASSON--140.00500.003,500.00-3,140.00
65OMAR1,640.00-----1,640.00
76OMRAAN-5,640.00-546.00---6,186.00
8TOTAL6,240.005,930.00524.001,336.0015,500.004,000.0010,998.00
REPORT
Cell Formulas
RangeFormula
I2:I8I2=C2-D2+E2-F2+G2-H2
C8:H8C8=SUM(C2:C7)

I hope somebody help.
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
Try this:

VBA Code: 
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

🤗
 
Upvote 0
Awesome !
can fill borders around the cells , please?
 
Upvote 0
Ali M said:
Awesome !
can fill borders around the cells , please?
Click to expand...

Try:
VBA Code: 
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

😇
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

A
  • Solved
Extraction last row based on specific words and put in account column(debit,credit)
Replies
4
Views
199
Alaa mg
A
A
  • Solved
Extract duplicates dates and insert TOTAL row for each duplicates dates
Replies
4
Views
131
Alaa mg
A
O
  • Solved
Merge data in listbox based on another listbox after search for name and dates
Replies
6
Views
187
Omran Y
O
M
  • Solved
How merge amounts into textbox based on two comboboxes instead of one combobox
Replies
6
Views
312
Maklil
M
O
  • Solved
Put amount in DEBIT,CREDIT columns based on matching part of item
Replies
9
Views
207
Omran Y
O

Forum statistics

Threads
1,224,813
Messages
6,181,111
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top