Combine Tables (without Total Row) into Master Tables (With Total Sum Row) based on specific sheet Like 1,2,3 to 24

[Kalim Shaikh]

I have 27 sheets in a workbook they contain sheets Names 'Summary","Checking","Recheck" and "1.2.3 to 24" in Sheets "1 to 24" Contains tables with header row range ("A12:L") and last row contains total row.

Invoice No	Date	Month	Particulars	Nature	Invoice Issue	Credit Note	Claim/ Bonus	1% GST	Sale Return	Cheque/Online Received	Balance
				CR							-
000225	15	Jul-23	Issued Invoice.000225 Amount	DR	305,254.00​						305,254.00
											-
TotalRow			Total Amount		305,254.00	-	-	-	-	-	305,254.00

I want Tables in Sheets "1 to 24" (without Total Row) will be combined in a new Table "Final" in Range ("A12:M) Sheet Name "Recheck" (Include xlTotalsCalculationSum Row) (If possible to add a new column named "Reference". That include table name or sheet Name for reference). Leave the column "Balance" blank so that the formula can be applied.

Distribution Account Ledgers.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3
4
5
6
7
8
9
10				"Final" Table
11	Table Name" Final"
12	Invoice No	Date	Month	Particulars	Nature	Invoice Issue	Credit Note	Claim/ Bonus	1% GST	Sale Return	Cheque/Online Received	Balance	Reference
13	000007	11	Jan-23	Invoice Amount	DR	907481.25
14	000017	27	Jan-23	Invoice Amount	DR	51,408.00
15	0	30	Jan-23	Received Online Amount	DR						200,000.00
16	-	31	Jan-23	Deduct Claim/Bonus Amount	DR			9804.75
17	000022	3	Feb-23	Issued Invoice Amount	DR	19125.00
18	000031	17	Feb-23	Issued Invoice Amount	DR	215,424.00
19	000044	22	Feb-23	Issued Invoice Amount	DR	53550.00
20	-	28	Feb-23	Deduct Claim/Bonus Amount	DR			16745.21
21	000059	2	Mar-23	Issued Invoice Amount	DR	99259.00
22	-	7	Mar-23	Received Online Amount	DR						140,000.00
23	000089	20	Mar-23	Issued Invoice Amount	DR	71375.00
24	000101	29	Mar-23	Issued Invoice Amount	DR	147,033.00
25	-	5	Apr-23	Deduct Claim/Bonus Amount	DR			43128.26
26	-	5	Apr-23	Received Online Amount	DR						186,000.00
27				Total Amount		1,564,655.25	-	69,678.22	-	-	526,000.00
28
ReCheck

Cell Formulas
Range	Formula
E13:E26	E13	=IF(OR(F13>0,G13>0,H13>0,I13>0,J13>0,K13>0), "DR", "CR")
F27	F27	=SUBTOTAL(109,[Invoice Issue])
G27	G27	=SUBTOTAL(109,[Credit Note])
H27	H27	=SUBTOTAL(109,[Claim/ Bonus])
I27	I27	=SUBTOTAL(109,[1% GST])
J27	J27	=SUBTOTAL(109,[Sale Return])
K27	K27	=SUBTOTAL(109,[Cheque/Online Received])

Actually I want to recheck the account so that there is no mistake. This file contains the following macro which is working fine and the result is in the "checking" sheet. I need another code that aggregates the data in the "Recheck" Sheet as I have shown above. Below code already work in workbook:-

Sub CombineTables(loDest As ListObject, Optional lcSource As ListColumn)

Dim ws              As Worksheet
Dim lo              As ListObject
Dim lc              As ListColumn
Dim rDest           As Range
Dim lDestRows       As Long
Dim lSourceRows     As Long

Application.ScreenUpdating = False

If lcSource Is Nothing Then Set lcSource = loDest.ListColumns(1)
If loDest.ListRows.Count > 0 Then loDest.DataBodyRange.Delete

For Each ws In ActiveWorkbook.Worksheets
    For Each lo In ws.ListObjects
        If lo <> loDest Then
            With lo
                If InStr(.Name, loDest.Name & "_") > 0 Then
                    On Error Resume Next
                    lDestRows = loDest.ListRows.Count
                    On Error GoTo 0
                    lSourceRows = .ListRows.Count
                    If lSourceRows > 0 Then

                        'Work out where we want to paste the data to
                        Set rDest = loDest.HeaderRowRange.Offset(1 + lDestRows).Resize(lSourceRows)

                        'Resize the destination table
                        loDest.Resize loDest.Range.Resize(1 + lSourceRows + lDestRows)

                        For Each lc In .ListColumns
                         Intersect(loDest.ListColumns(lc.Name).Range.EntireColumn, rDest).Value2 = lc.DataBodyRange.Value
                        Next lc
                        Set lc = Nothing
                        On Error Resume Next
                        Set lc = .ListColumns(lcSource.Name)
                        On Error GoTo 0
                        If lc Is Nothing Then Intersect(lcSource.Range, rDest.EntireRow).Value2 = ws.Name
                    End If
                End If
            End With
        End If
    Next lo
Next ws

Application.ScreenUpdating = True

End Sub
Sub CombineTables_Caller()
CombineTables [Kalim].ListObject, [Kalim].ListObject.ListColumns("Source")
End Sub

 

[DanteAmor]

Try this:

Sub recheck()
  Dim shR As Worksheet, sh As Worksheet
  Dim lstObj As ListObject, lo As ListObject
  Dim i As Long, lr As Long, lr2 As Long
 
  Application.ScreenUpdating = False
 
  Set shR = Sheets("ReCheck")
  On Error Resume Next
    Set lstObj = shR.ListObjects(1)
    lstObj.Unlist
  On Error GoTo 0
  shR.Rows("13:" & Rows.Count).Clear
   
  For i = 1 To 24
    Set sh = Sheets(CStr(i))
    Set lstObj = sh.ListObjects(1)
    lr = shR.Range("A:M").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
    lstObj.DataBodyRange.Copy
    shR.Range("A" & lr).PasteSpecial xlPasteValues
    shR.Range("A" & lr).PasteSpecial xlPasteFormats
    lr2 = shR.Range("A:L").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    shR.Range("M" & lr & ":M" & lr2).Value = sh.Name
  Next

  lr2 = shR.Range("A:M").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
  shR.Range("L13:L" & lr2).ClearContents
  shR.ListObjects.Add(xlSrcRange, shR.Range("A12:M" & lr2), , xlYes).Name = "Final"
  shR.ListObjects("Final").ShowTotals = True
  With shR.Range("E13:E" & lr2)
    .Formula = "=IF(OR(F13>0,G13>0,H13>0,I13>0,J13>0,K13>0), ""DR"", ""CR"")"
  End With
  For i = 6 To 12
    shR.ListObjects("Final").ListColumns(i).TotalsCalculation = xlTotalsCalculationSum
  Next
  shR.Range("M:M").NumberFormat = "General"
  shR.Range("A:M").EntireColumn.AutoFit
  Application.ScreenUpdating = True
  Application.CutCopyMode = False
End Sub

The macro includes formulas and subtotals.

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[Kalim Shaikh]

Thank you very much sir I have no words to thank you.

That it gave more surprising results than expected. I didn't expect to get an answer. But there are precious/sincere people like you in this world who populate it all. Thank you very much sir۔