Create multiple tables from one table (VBA code please)

A

arunsjain

Board Regular
Joined
Apr 29, 2016
Messages
130
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have a table where rows range is inconsistent. I need to separate this table in multiple different tables based on customer. This table changes all the time. It can have more or less rows. Following is the table before and after sorting:

Before Sorting

[TABLE="width: 445"]
<tbody>[TR]
[TD]Customer
[/TD]
[TD]Current
[/TD]
[TD]>30 days
[/TD]
[TD]>60 days
[/TD]
[TD]>90 days
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$101,297
[/TD]
[TD]$117
[/TD]
[TD]$3,978
[/TD]
[TD]$178
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$95
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$76,083
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$136,326
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$133,055
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$58,009
[/TD]
[TD]$34,776
[/TD]
[TD]$108,460
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$11,860
[/TD]
[TD]$6,259
[/TD]
[TD]$139
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$32,145
[/TD]
[TD]$0
[/TD]
[TD]$32
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$117,104
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$441,581
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$102,671
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$185,991
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$225
[/TD]
[TD]$210
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$32,035
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$9,664
[/TD]
[TD]$0
[/TD]
[TD]$4,029
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$41,391
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$43,173
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$23,566
[/TD]
[TD]$0
[/TD]
[TD]$32,139
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$94,915
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$18,157
[/TD]
[TD]$31,712
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$2,154
[/TD]
[TD]$2,911
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$94,220
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$1,295
[/TD]
[TD]$0
[/TD]
[TD]$999
[/TD]
[TD]$2,967
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$0
[/TD]
[TD]$33,752
[/TD]
[TD]$75,041
[/TD]
[TD]$85,164
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$49,568
[/TD]
[TD]$52,100
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$212,639
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$420
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$162,380
[/TD]
[TD]$34
[/TD]
[TD]$127
[/TD]
[TD]$1,464
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$432,486
[/TD]
[TD]$1,455
[/TD]
[TD]$3,325
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$20,756
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$407,687
[/TD]
[TD]$197,369
[/TD]
[TD]$36,838
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$15,307
[/TD]
[TD]$5,727
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$406,307
[/TD]
[TD]$344
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$885,034
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$4,270
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$101,504
[/TD]
[TD]$1,189
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$144,265
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$111,031
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$117,023
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$18,920
[/TD]
[TD]$37,033
[/TD]
[TD]$11,387
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$7,701
[/TD]
[TD]$0
[/TD]
[TD]$11
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Total
[/TD]
[TD="align: right"]$4,833,260
[/TD]
[TD="align: right"]$370,154
[/TD]
[TD="align: right"]$297,137
[/TD]
[TD="align: right"]$125,028
[/TD]
[/TR]
</tbody>[/TABLE]


After Sorting

[TABLE="width: 445"]
<tbody>[TR]
[TD]Customer
[/TD]
[TD]Current
[/TD]
[TD]>30 days
[/TD]
[TD]>60 days
[/TD]
[TD]>90 days
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$101,297
[/TD]
[TD]$117
[/TD]
[TD]$3,978
[/TD]
[TD]$178
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$95
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$76,083
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$136,326
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$133,055
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$58,009
[/TD]
[TD]$34,776
[/TD]
[TD]$108,460
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$11,860
[/TD]
[TD]$6,259
[/TD]
[TD]$139
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$32,145
[/TD]
[TD]$0
[/TD]
[TD]$32
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$117,104
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$441,581
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$102,671
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$185,991
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor A
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$225
[/TD]
[TD]$210
[/TD]
[/TR]
[TR]
[TD]Subtotal
[/TD]
[TD="align: right"]$1,396,122
[/TD]
[TD="align: right"]$41,152
[/TD]
[TD="align: right"]$112,929
[/TD]
[TD="align: right"]$389
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Customer
[/TD]
[TD]Current
[/TD]
[TD]>30 days
[/TD]
[TD]>60 days
[/TD]
[TD]>90 days
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$32,035
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$9,664
[/TD]
[TD]$0
[/TD]
[TD]$4,029
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$41,391
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$43,173
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$23,566
[/TD]
[TD]$0
[/TD]
[TD]$32,139
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$94,915
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$18,157
[/TD]
[TD]$31,712
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$2,154
[/TD]
[TD]$2,911
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$94,220
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor B
[/TD]
[TD]$1,295
[/TD]
[TD]$0
[/TD]
[TD]$999
[/TD]
[TD]$2,967
[/TD]
[/TR]
[TR]
[TD]Subtotal
[/TD]
[TD="align: right"]$340,260
[/TD]
[TD="align: right"]$0
[/TD]
[TD="align: right"]$57,479
[/TD]
[TD="align: right"]$37,591
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Customer
[/TD]
[TD]Current
[/TD]
[TD]>30 days
[/TD]
[TD]>60 days
[/TD]
[TD]>90 days
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$0
[/TD]
[TD]$33,752
[/TD]
[TD]$75,041
[/TD]
[TD]$85,164
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$49,568
[/TD]
[TD]$52,100
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$212,639
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$420
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$162,380
[/TD]
[TD]$34
[/TD]
[TD]$127
[/TD]
[TD]$1,464
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$432,486
[/TD]
[TD]$1,455
[/TD]
[TD]$3,325
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$20,756
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$407,687
[/TD]
[TD]$197,369
[/TD]
[TD]$36,838
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$15,307
[/TD]
[TD]$5,727
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$406,307
[/TD]
[TD]$344
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$885,034
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$4,270
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$101,504
[/TD]
[TD]$1,189
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$144,265
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$111,031
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$117,023
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$18,920
[/TD]
[TD]$37,033
[/TD]
[TD]$11,387
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Debtor C
[/TD]
[TD]$7,701
[/TD]
[TD]$0
[/TD]
[TD]$11
[/TD]
[TD]$0
[/TD]
[/TR]
[TR]
[TD]Subtotal
[/TD]
[TD="align: right"]$3,096,878
[/TD]
[TD="align: right"]$329,002
[/TD]
[TD="align: right"]$126,730
[/TD]
[TD="align: right"]$87,049
[/TD]
[/TR]
</tbody>[/TABLE]


Is there any VBA code to do this quickly? Highly appreciate your help.

Cheers!!
 
Last edited:

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
arunsjain said:
Hi,

I have a table where rows range is inconsistent. I need to separate this table in multiple different tables based on customer. This table changes all the time. It can have more or less rows. Following is the table before and after sorting:

Is there any VBA code to do this quickly? Highly appreciate your help.

Cheers!!
Click to expand...


Hello!

Try this: This macro should split the data as per your spec... and the data can be anywhere on a worksheet (doesn't have to start in cell A1).

NOTE: Define the worksheet and the data range by editing the CONST information at the beginning of the macro.

Hope this helps!


Code: 
Sub SplitData()




'#############################################################################################################################


' With a table of N columns (you can have as few or many as you like)
' using the FIRST column of that data as the information to split by
' this macro: SORTS the data on the FIRST column (essential)
' removes the last row if it currently has the word TOTAL in the first column
' then creates a split of R rows (you can define the number of rows)
' separating the one table into X number of tables.


' Each newly created table then has the HEADINGS added to the TOP
' and SUBTOTALS added to the BOTTOM




' IMPORTANT NOTES:


' **************************************************************
' The data in the table MUST be the LAST ROW in the spreadsheet.   <<  <<  <<
' **************************************************************


' i.e. if the data ends on row 100 and you also have a cell containing data that is in a row > 100 (say cell J210)
' the LASTROW returned will be 210 - which means you'll get unwanted subtotalling at the bottom of the sheet
' BE AWARE - if a cell beyond the data contains a "SPACE" character (i.e. isn't actually a NULL cell), the same will occur


' The MINIMUM number of rows to insert MUST be 3: [Const RowsToInsert]


' If the Number of Rows to Insert is set to 3, there will be a GAP of [1] ROW between the newly separated tables
' Equally, if the Number of Rows to Insert is set to 10, there will be a GAP of [8] ROWs between the newly separated tables
' This is because [2] of the Rows are used for (i) Headings and (ii) SubTotals


' Your data can be anywhere on the worksheet; just edit the CONST information to define which worksheet and the data structure.


'#############################################################################################################################




    Const SheetName = "Sheet16"         'The name of the worksheet / worksheet tab with your data in it


    Const DataStartRow = 2              'The ROW were the DATA starts. (The 1st line of DATA will be just below the COLUMN HEADINGS)
                                        'thus if your column headings are in row 1, your data starts in row [2]


    Const DataStartCol = 1              'The COLUMN where the DATA starts. (If your data begins in A1, it'll be column [1]
                                        'if you data begins in D1, it'll be column[4]  (A=1, B=2, C=3, D=4.. and so on)


    Const NoOfCols = 5                  'The number of columns of data to work with


    Const RowsToInsert = 3              'The number of rows you want to insert when splitting the data in separate tables






    Dim LastRow As Integer
    Dim RCntr As Integer
    
    Dim CurPtr As String
    Dim NextPtr As String
    Dim TmpDataStartRow As Integer
    Dim RowInsCntr As Integer
    
    Dim SubTotCntr As Integer
    Dim LastRowEnd As Integer
    Dim SubTotPtr()


    'Do CONST error trapping
    If RowsToInsert < 3 Then
        MsgBox "The number of ROWS to INSERT [RowsToInsert CONST] must be 3 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If DataStartRow < 2 Then
        MsgBox "The Start Row of your data [DataStartRow CONST] must be 2 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If DataStartCol < 1 Then
        MsgBox "The Start Column of your data [DataStartCol CONST] must be 1 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If NoOfCols < 1 Then
        MsgBox "The Number of Columns of data [NoOfCols CONST] must be 1 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    SubTotCntr = 1


    'Get the Last Row in the worksheet
    LastRow = Sheets(SheetName).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row




    'Get rid of the existing TOTAL row at the bottom of the spreadsheet
    If UCase(Sheets(SheetName).Cells(LastRow, DataStartCol).Value) = "TOTAL" Then
        Sheets(SheetName).Range(Cells(LastRow, DataStartCol).Address, Cells(LastRow, NoOfCols + DataStartCol - 1).Address).ClearContents
        LastRow = LastRow - 1
    End If
    
    'Ensure the data is sorted
    Sheets(SheetName).Range(Cells(DataStartRow, DataStartCol).Address, Cells(LastRow, NoOfCols + DataStartCol - 1).Address).Sort Key1:=Cells(DataStartRow, DataStartCol), order1:=xlAscending, Header:=xlNo
    
    'Error trap - make sure NextPrt counter doesn't go past row 1
    If DataStartRow < 2 Then TmpDataStartRow = 2 Else TmpDataStartRow = DataStartRow + 1


    For RCntr = LastRow To TmpDataStartRow Step -1
        With Sheets(SheetName)
            CurPtr = UCase(Trim(.Range(Cells(RCntr, DataStartCol).Address).Value))
            NextPtr = UCase(Trim(.Range(Cells(RCntr - 1, DataStartCol).Address).Value))
            If CurPtr <> NextPtr Then
            
                'Insert the rows
                For RowInsCntr = 1 To RowsToInsert
                    Sheets(SheetName).Range(Cells(RCntr, DataStartCol).Address, Cells(RCntr, NoOfCols + DataStartCol - 1).Address).Insert shift:=xlShiftDown
                Next RowInsCntr
                
                'Put Headings
                Sheets(SheetName).Range(Cells(RCntr + RowsToInsert - 1, DataStartCol).Address, Cells(RCntr + RowsToInsert - 1, NoOfCols + DataStartCol - 1).Address).Value = Sheets(SheetName).Range(Cells(DataStartRow - 1, DataStartCol).Address, Cells(DataStartRow - 1, NoOfCols + DataStartCol - 1).Address).Value
                
                'Embolden
                Sheets(SheetName).Range(Cells(RCntr + RowsToInsert - 1, DataStartCol).Address, Cells(RCntr + RowsToInsert - 1, NoOfCols + DataStartCol - 1).Address).Font.Bold = True
            
                If SubTotCntr = 1 Then
                    Sheets(SheetName).Range(Cells(LastRow + RowsToInsert + 1, DataStartCol).Address, Cells(LastRow + RowsToInsert + 1, DataStartCol).Address).Value = "Subtotal"
                    Sheets(SheetName).Range(Cells(LastRow + RowsToInsert + 1, DataStartCol + 1).Address, Cells(LastRow + RowsToInsert + 1, NoOfCols + DataStartCol - 1).Address).Formula = "=SUM(" & Range(Cells(RCntr + RowsToInsert, DataStartCol + 1).Address(False, False), Cells(LastRow + RowsToInsert, DataStartCol + 1).Address(False, False)).Address(False, False) & ")"
                    Sheets(SheetName).Range(Cells(LastRow + RowsToInsert + 1, DataStartCol).Address, Cells(LastRow + RowsToInsert + 1, NoOfCols + DataStartCol - 1).Address).Font.Bold = True
                    SubTotCntr = SubTotCntr + 1
                    LastRowEnd = RCntr - 1
                  Else
                    Sheets(SheetName).Range(Cells(LastRowEnd + RowsToInsert + 1, DataStartCol).Address, Cells(LastRowEnd + RowsToInsert + 1, DataStartCol).Address).Value = "Subtotal"
                    Sheets(SheetName).Range(Cells(LastRowEnd + RowsToInsert + 1, DataStartCol + 1).Address, Cells(LastRowEnd + RowsToInsert + 1, NoOfCols + DataStartCol - 1).Address).Formula = "=SUM(" & Range(Cells(RCntr + RowsToInsert, DataStartCol + 1).Address(False, False), Cells(LastRowEnd + RowsToInsert, DataStartCol + 1).Address(False, False)).Address(False, False) & ")"
                    Sheets(SheetName).Range(Cells(LastRowEnd + RowsToInsert + 1, DataStartCol).Address, Cells(LastRowEnd + RowsToInsert + 1, NoOfCols + DataStartCol - 1).Address).Font.Bold = True
                    SubTotCntr = SubTotCntr + 1
                    LastRowEnd = RCntr - 1
                End If
            End If
        End With
        
        If RCntr = TmpDataStartRow Then
            Debug.Print RCntr
            Sheets(SheetName).Range(Cells(LastRowEnd + 1, DataStartCol).Address, Cells(LastRowEnd + 1, DataStartCol).Address).Value = "Subtotal"
            Sheets(SheetName).Range(Cells(LastRowEnd + 1, DataStartCol + 1).Address, Cells(LastRowEnd + 1, NoOfCols + DataStartCol - 1).Address).Formula = "=SUM(" & Range(Cells(RCntr - 1, DataStartCol + 1).Address(False, False), Cells(LastRowEnd, DataStartCol + 1).Address(False, False)).Address(False, False) & ")"
            Sheets(SheetName).Range(Cells(LastRowEnd + 1, DataStartCol).Address, Cells(LastRowEnd + 1, NoOfCols + DataStartCol - 1).Address).Font.Bold = True
        End If
    
    
    
    Next RCntr
    
    Application.ScreenUpdating = True


End Sub
 
Upvote 0
Thank you so much MartyS. I will try this and let you know.

Kind Regards
Arun
 
Upvote 0
Worked perfectly. Great!!! Thank you so much. Highly appreciated.

Kind Regards
Arun


MartyS said:
Hello!

Try this: This macro should split the data as per your spec... and the data can be anywhere on a worksheet (doesn't have to start in cell A1).

NOTE: Define the worksheet and the data range by editing the CONST information at the beginning of the macro.

Hope this helps!


Code: 
Sub SplitData()




'#############################################################################################################################


' With a table of N columns (you can have as few or many as you like)
' using the FIRST column of that data as the information to split by
' this macro: SORTS the data on the FIRST column (essential)
' removes the last row if it currently has the word TOTAL in the first column
' then creates a split of R rows (you can define the number of rows)
' separating the one table into X number of tables.


' Each newly created table then has the HEADINGS added to the TOP
' and SUBTOTALS added to the BOTTOM




' IMPORTANT NOTES:


' **************************************************************
' The data in the table MUST be the LAST ROW in the spreadsheet.   <<  <<  <<
' **************************************************************


' i.e. if the data ends on row 100 and you also have a cell containing data that is in a row > 100 (say cell J210)
' the LASTROW returned will be 210 - which means you'll get unwanted subtotalling at the bottom of the sheet
' BE AWARE - if a cell beyond the data contains a "SPACE" character (i.e. isn't actually a NULL cell), the same will occur


' The MINIMUM number of rows to insert MUST be 3: [Const RowsToInsert]


' If the Number of Rows to Insert is set to 3, there will be a GAP of [1] ROW between the newly separated tables
' Equally, if the Number of Rows to Insert is set to 10, there will be a GAP of [8] ROWs between the newly separated tables
' This is because [2] of the Rows are used for (i) Headings and (ii) SubTotals


' Your data can be anywhere on the worksheet; just edit the CONST information to define which worksheet and the data structure.


'#############################################################################################################################




    Const SheetName = "Sheet16"         'The name of the worksheet / worksheet tab with your data in it


    Const DataStartRow = 2              'The ROW were the DATA starts. (The 1st line of DATA will be just below the COLUMN HEADINGS)
                                        'thus if your column headings are in row 1, your data starts in row [2]


    Const DataStartCol = 1              'The COLUMN where the DATA starts. (If your data begins in A1, it'll be column [1]
                                        'if you data begins in D1, it'll be column[4]  (A=1, B=2, C=3, D=4.. and so on)


    Const NoOfCols = 5                  'The number of columns of data to work with


    Const RowsToInsert = 3              'The number of rows you want to insert when splitting the data in separate tables






    Dim LastRow As Integer
    Dim RCntr As Integer
    
    Dim CurPtr As String
    Dim NextPtr As String
    Dim TmpDataStartRow As Integer
    Dim RowInsCntr As Integer
    
    Dim SubTotCntr As Integer
    Dim LastRowEnd As Integer
    Dim SubTotPtr()


    'Do CONST error trapping
    If RowsToInsert < 3 Then
        MsgBox "The number of ROWS to INSERT [RowsToInsert CONST] must be 3 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If DataStartRow < 2 Then
        MsgBox "The Start Row of your data [DataStartRow CONST] must be 2 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If DataStartCol < 1 Then
        MsgBox "The Start Column of your data [DataStartCol CONST] must be 1 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If NoOfCols < 1 Then
        MsgBox "The Number of Columns of data [NoOfCols CONST] must be 1 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    SubTotCntr = 1


    'Get the Last Row in the worksheet
    LastRow = Sheets(SheetName).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row




    'Get rid of the existing TOTAL row at the bottom of the spreadsheet
    If UCase(Sheets(SheetName).Cells(LastRow, DataStartCol).Value) = "TOTAL" Then
        Sheets(SheetName).Range(Cells(LastRow, DataStartCol).Address, Cells(LastRow, NoOfCols + DataStartCol - 1).Address).ClearContents
        LastRow = LastRow - 1
    End If
    
    'Ensure the data is sorted
    Sheets(SheetName).Range(Cells(DataStartRow, DataStartCol).Address, Cells(LastRow, NoOfCols + DataStartCol - 1).Address).Sort Key1:=Cells(DataStartRow, DataStartCol), order1:=xlAscending, Header:=xlNo
    
    'Error trap - make sure NextPrt counter doesn't go past row 1
    If DataStartRow < 2 Then TmpDataStartRow = 2 Else TmpDataStartRow = DataStartRow + 1


    For RCntr = LastRow To TmpDataStartRow Step -1
        With Sheets(SheetName)
            CurPtr = UCase(Trim(.Range(Cells(RCntr, DataStartCol).Address).Value))
            NextPtr = UCase(Trim(.Range(Cells(RCntr - 1, DataStartCol).Address).Value))
            If CurPtr <> NextPtr Then
            
                'Insert the rows
                For RowInsCntr = 1 To RowsToInsert
                    Sheets(SheetName).Range(Cells(RCntr, DataStartCol).Address, Cells(RCntr, NoOfCols + DataStartCol - 1).Address).Insert shift:=xlShiftDown
                Next RowInsCntr
                
                'Put Headings
                Sheets(SheetName).Range(Cells(RCntr + RowsToInsert - 1, DataStartCol).Address, Cells(RCntr + RowsToInsert - 1, NoOfCols + DataStartCol - 1).Address).Value = Sheets(SheetName).Range(Cells(DataStartRow - 1, DataStartCol).Address, Cells(DataStartRow - 1, NoOfCols + DataStartCol - 1).Address).Value
                
                'Embolden
                Sheets(SheetName).Range(Cells(RCntr + RowsToInsert - 1, DataStartCol).Address, Cells(RCntr + RowsToInsert - 1, NoOfCols + DataStartCol - 1).Address).Font.Bold = True
            
                If SubTotCntr = 1 Then
                    Sheets(SheetName).Range(Cells(LastRow + RowsToInsert + 1, DataStartCol).Address, Cells(LastRow + RowsToInsert + 1, DataStartCol).Address).Value = "Subtotal"
                    Sheets(SheetName).Range(Cells(LastRow + RowsToInsert + 1, DataStartCol + 1).Address, Cells(LastRow + RowsToInsert + 1, NoOfCols + DataStartCol - 1).Address).Formula = "=SUM(" & Range(Cells(RCntr + RowsToInsert, DataStartCol + 1).Address(False, False), Cells(LastRow + RowsToInsert, DataStartCol + 1).Address(False, False)).Address(False, False) & ")"
                    Sheets(SheetName).Range(Cells(LastRow + RowsToInsert + 1, DataStartCol).Address, Cells(LastRow + RowsToInsert + 1, NoOfCols + DataStartCol - 1).Address).Font.Bold = True
                    SubTotCntr = SubTotCntr + 1
                    LastRowEnd = RCntr - 1
                  Else
                    Sheets(SheetName).Range(Cells(LastRowEnd + RowsToInsert + 1, DataStartCol).Address, Cells(LastRowEnd + RowsToInsert + 1, DataStartCol).Address).Value = "Subtotal"
                    Sheets(SheetName).Range(Cells(LastRowEnd + RowsToInsert + 1, DataStartCol + 1).Address, Cells(LastRowEnd + RowsToInsert + 1, NoOfCols + DataStartCol - 1).Address).Formula = "=SUM(" & Range(Cells(RCntr + RowsToInsert, DataStartCol + 1).Address(False, False), Cells(LastRowEnd + RowsToInsert, DataStartCol + 1).Address(False, False)).Address(False, False) & ")"
                    Sheets(SheetName).Range(Cells(LastRowEnd + RowsToInsert + 1, DataStartCol).Address, Cells(LastRowEnd + RowsToInsert + 1, NoOfCols + DataStartCol - 1).Address).Font.Bold = True
                    SubTotCntr = SubTotCntr + 1
                    LastRowEnd = RCntr - 1
                End If
            End If
        End With
        
        If RCntr = TmpDataStartRow Then
            Debug.Print RCntr
            Sheets(SheetName).Range(Cells(LastRowEnd + 1, DataStartCol).Address, Cells(LastRowEnd + 1, DataStartCol).Address).Value = "Subtotal"
            Sheets(SheetName).Range(Cells(LastRowEnd + 1, DataStartCol + 1).Address, Cells(LastRowEnd + 1, NoOfCols + DataStartCol - 1).Address).Formula = "=SUM(" & Range(Cells(RCntr - 1, DataStartCol + 1).Address(False, False), Cells(LastRowEnd, DataStartCol + 1).Address(False, False)).Address(False, False) & ")"
            Sheets(SheetName).Range(Cells(LastRowEnd + 1, DataStartCol).Address, Cells(LastRowEnd + 1, NoOfCols + DataStartCol - 1).Address).Font.Bold = True
        End If
    
    
    
    Next RCntr
    
    Application.ScreenUpdating = True


End Sub
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question Question
Create multiple tables from one table based on change in field name
Replies
8
Views
690
welshgasman
welshgasman

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,636
Latest member
laura12345

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