Previous Topic Next Topic

Split data into multiple sheets using macro

Solved/Closed

Suhas - May 31, 2011 at 02:31 AM
rizvisa1

Posts: 4479
Registration date: Thursday January 28, 2010
Status: Contributor
Last seen: May 5, 2022

- May 31, 2011 at 09:31 PM

Hello,

I have an excel sheet with the data in following manner.

a b c d
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4

e f g h
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5

i j k l
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5
6 6 6 6

Above there is a blank row after each table data. Now I want to split this data from one sheet to multiple sheets like below and also make the first row BOLD in each sheet which represents the table heading.

DataSheet1
a b c d
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4

DataSheet2
e f g h
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5

DataSheet3
i j k l
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5
6 6 6 6

Please advise how I can do it using macro in excel.

How to split one excel sheet into multiple files using macro
Split excel sheet into multiple sheets based on rows vba - Best answers
How to split excel sheet into multiple worksheets based on rows - Best answers
Split a workbook into individual files in Excel - Guide
Split one excel sheet into multiple sheets based on column value ✓ - Forum - Excel
One excel sheet to multiple sheets - Guide
Copy excel sheet to another file - Guide
How to create a master sheet from multiple sheets in excel ✓ - Forum - Excel

3 replies

Answer 1 / 3

rizvisa1

Posts: 4479
Registration date: Thursday January 28, 2010
Status: Contributor
Last seen: May 5, 2022

769
May 31, 2011 at 06:20 AM

make a back copy of the file
open excel
press alt + f11 at the same time
click on insert and insert a new module
paste the code below (after the instructions)
run the code by executing routine doSplitData

It will create or (recreate sheets) titled "datasheet1", "datasheet2" etc

Sub doSplitData()
    
  Dim lMaxRows                   As Long
  Dim sSheet                     As String
  Dim lStartRow                  As Long
  Dim lEndRow                    As Long
  Dim sFinalSheet                As String
  Dim iSheetCount                As Integer
  
   sSheet = "Sheet1"
   sFinalSheet = "DataSheet"
   iSheetCount = 0
   Application.ScreenUpdating = False
   With Sheets(sSheet)
      lMaxRows = getItemRowLocation("*", .Cells)
      lStartRow = 0
      lStartRow = getItemRowLocation("*", .Range(.Cells(lStartRow + 1, "A"), .Cells(lMaxRows, "A")), , False)
      Do While (lStartRow > 0)
         lEndRow = getItemRowLocation(vbNullString, .Range(.Cells(lStartRow + 1, "A"), .Cells(lMaxRows, "A")), , False)
    
         If (lEndRow > 0) _
         Then
            
         Else
            lEndRow = lMaxRows
         End If
         
         On Error Resume Next
         iSheetCount = iSheetCount + 1
         Application.DisplayAlerts = False
         Sheets(sFinalSheet & iSheetCount).Delete
         Application.DisplayAlerts = True
         Sheets.Add
         ActiveSheet.Name = sFinalSheet & iSheetCount
         Application.CutCopyMode = False
         .Rows(lStartRow & ":" & lEndRow).Copy
         With Sheets(sFinalSheet & iSheetCount)
            .Cells(1, 1).PasteSpecial
            Rows(1).Font.Bold = True
         End With
         Application.CutCopyMode = False
         lStartRow = getItemRowLocation("*", .Range(.Cells(lEndRow + 1, "A"), .Cells(lMaxRows + 1, "A")), , False)
      Loop
      Application.ScreenUpdating = True
   End With
End Sub
Public Function getItemRowLocation(sLookFor As String, _
                            rngSearch As Range, _
                            Optional bFullString As Boolean = True, _
                            Optional bLastOccurance As Boolean = True) As Long
' get last use row on the sheet

   Dim Cell             As Range
   Dim iLookAt          As Integer
   Dim iSearchDir       As Integer
   
   If (bFullString) _
   Then
      iLookAt = xlWhole
   Else
      iLookAt = xlPart
   End If
   
   If (bLastOccurance) _
   Then
      iSearchDir = xlPrevious
   Else
      iSearchDir = xlNext
   End If
   
   With rngSearch
      If (bLastOccurance) _
      Then
         Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, xlByRows, iSearchDir)
      Else
         Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, xlByRows, iSearchDir)
      End If
   End With
   
   If Cell Is Nothing Then
      getItemRowLocation = 0
   Else
      getItemRowLocation = Cell.Row
   End If
   Set Cell = Nothing
End Function

Answer 2 / 3

Suhas
May 31, 2011 at 02:36 AM

I am the one who asked this question.

Just want to add that the heading of each table will remain same/constant but the number of rows below each table heading will be dynamic.

Answer 3 / 3

Suhas
May 31, 2011 at 06:58 AM

Hi Rizvisa,

Many thanks for the script. But since there are many blank rows later in my output I am not getting the desired results. Please could you help to modify the script in such a way that it will execute in below fashion.

There are 13 set of tables in the first sheet. Each one will have start and end indicator as below.

JVMStart
a b c d
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
JVMEnd

JDBCStart
e f g h
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5
JDBCEnd

JMSStart
i j k l
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5
6 6 6 6
JMSEnd

MonitorPolicyStart
...
...
...
MonitorPolicyEnd

WebContainerStart
...
...
...
WebContainerEnd

VirtualHostStart
...
...
...
VirtualHostEnd

AdminConsoleStart
...
...
...
AdminConsoleEnd

ClusterStart
...
...
...
ClusterEnd

NodeGroupStart
...
...
...
NodeGroupEnd

PMIStart
...
...
...
PMIEnd

IPFilteringStart
...
...
...
IPFilteringEnd

AppResourcesStart
...
...
...
AppResourcesEnd

SecurityStart
...
...
...
SecurityEnd

Now I want 13 sheets to be created with their respective names like below. i.e. copying all the rows after and before the JVMStart and JVMEnd and putting it into new sheet with the name JVM. Similarly for rest of the tables.

"JVM" # This will be the sheet name - just need to remove the start/end suffix and use the indicator as the name
a b c d
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4

"JDBC"
e f g h
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5

"JMS"
i j k l
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5
6 6 6 6

and so on for the rest...

Many Thanks and appreciate your wonderful help.

rizvisa1

Posts: 4479
Registration date: Thursday January 28, 2010
Status: Contributor
Last seen: May 5, 2022

769
May 31, 2011 at 08:27 AM

What do you mean there are many blank rows later in your dataset. Unless there is a bug, the program is supposed to find first non-blank cell in column A. and then find the first blank cell that comes after this cell. Copies all the information into a new sheet and then starting from the one row down from the last row blank row that was found, again repeat. Basically get the group.

Suhas
May 31, 2011 at 08:54 AM

Hi rizvisa,

The script you gave is perfect. But in my data the later portion is having blank cells in column A which are part of a group and not supposed to be extracted individually. So I modified my script which pulls the data in such a way that for every group there will be a start and end indicator in column A. So all the rows within the indicators need to be pasted to a new sheet including the blank cells inbetween if any. Please help with the script for my requirements. Many thanks.

rizvisa1

Posts: 4479
Registration date: Thursday January 28, 2010
Status: Contributor
Last seen: May 5, 2022

769
May 31, 2011 at 09:01 AM

Could you please upload a sample EXCEL file WITH sample data, macro, formula , conditional formatting etc on some shared site like https://accounts.google.com/ServiceLogin?passive=1209600&continue=https://docs.google.com/&followup=https://docs.google.com/&emr=1 http://wikisend.com/ , http://www.editgrid.com/ etc
AND post back here the link to allow better understanding of how it is now and how you foresee. Based on the sample book, could you re-explain your problem too.

Note: your data need not be to be real data but a good representative of how data looks like

Suhas
May 31, 2011 at 09:09 AM

With the script u gave - the problem comes for me when data is like

a b c d
1 2 3 5
6 7 8 9

0 1 2 3

0 4 5 6

Now above, the 4th and 6th row is having blank cells but they are still the part of group/table with heading "a b c d". In this situation the macro creates separate sheet for the 5th and 7th row. So now I added a start and end indicator for each group. Like that there are 13 groups. Above eg will look like this with the indicators.

JVMStart
a b c d
1 2 3 5
6 7 8 9

0 1 2 3

0 4 5 6
JVMEnd

Hope you understand now.

rizvisa1

Posts: 4479
Registration date: Thursday January 28, 2010
Status: Contributor
Last seen: May 5, 2022

769
May 31, 2011 at 09:13 AM

please upload an excel file as mentioned above

rizvisa1

Posts: 4479
Registration date: Thursday January 28, 2010
Status: Contributor
Last seen: May 5, 2022

769
May 31, 2011 at 11:21 AM

Based on your first example (original), this is a modifed script. In this case a set is marked by a complete blank row ( as opposed to column A in earlier solution). Rest hold true and still is valid

Sub doSplitData() 
     
  Dim lMaxRows                   As Long 
  Dim sSheet                     As String 
  Dim lStartRow                  As Long 
  Dim lEndRow                    As Long 
  Dim sFinalSheet                As String 
  Dim iSheetCount                As Integer 
  Dim lMaxCols                   As Integer 
   
   sSheet = "Sheet1" 
   sFinalSheet = "DataSheet" 
   iSheetCount = 0 
   Application.ScreenUpdating = False 
   With Sheets(sSheet) 
      lMaxCols = getItemLocation("*", .Cells, bFindRow:=False) 
      lMaxCols = lMaxCols + 1 
      lMaxRows = getItemLocation("*", .Cells) 
       
      With .Range(.Cells(1, lMaxCols), .Cells(lMaxRows, lMaxCols)) 
         .NumberFormat = "General" 
         .FormulaR1C1 = "=IF(CountA(RC1:RC" & lMaxCols - 1 & ")>0,1,0)" 
         Application.CutCopyMode = False 
         .Copy 
         .PasteSpecial xlPasteValues 
         Application.CutCopyMode = False 
      End With 
       
      lStartRow = 0 
      lStartRow = getItemLocation(1, .Range(.Cells(lStartRow + 1, lMaxCols), .Cells(lMaxRows, lMaxCols)), , False) 
      Do While (lStartRow > 0) 
         lEndRow = getItemLocation(0, .Range(.Cells(lStartRow + 1, lMaxCols), .Cells(lMaxRows, lMaxCols)), , False) 
         If (lEndRow = 0) Then lEndRow = lMaxRows 
         iSheetCount = iSheetCount + 1 
         Application.DisplayAlerts = False 
         On Error Resume Next 
         Sheets(sFinalSheet & iSheetCount).Delete 
         Err.Clear 
         On Error GoTo 0 
         Application.DisplayAlerts = True 
         Sheets.Add 
         ActiveSheet.Name = sFinalSheet & iSheetCount 
          
         Application.CutCopyMode = False 
         .Range(.Cells(lStartRow, 1), .Cells(lEndRow, lMaxCols - 1)).Copy 
         With Sheets(sFinalSheet & iSheetCount) 
            .Cells(1, 1).PasteSpecial 
            .Rows(1).Font.Bold = True 
         End With 
         Application.CutCopyMode = False 
         lStartRow = getItemLocation(1, .Range(.Cells(lEndRow + 1, lMaxCols), .Cells(lMaxRows + 1, lMaxCols)), , False) 
      Loop 
      .Range(.Cells(1, lMaxCols), .Cells(lMaxRows, lMaxCols)).ClearContents 
      Application.ScreenUpdating = True 
   End With 
End Sub 

Public Function getItemLocation(sLookFor As String, _ 
                                rngSearch As Range, _ 
                                Optional bFullString As Boolean = True, _ 
                                Optional bLastOccurance As Boolean = True, _ 
                                Optional bFindRow As Boolean = True) As Long 
    
   Dim Cell             As Range 
   Dim iLookAt          As Integer 
   Dim iSearchDir       As Integer 
   Dim iSearchOdr       As Integer 
    
   If (bFullString) _ 
   Then 
      iLookAt = xlWhole 
   Else 
      iLookAt = xlPart 
   End If 
   If (bLastOccurance) _ 
   Then 
      iSearchDir = xlPrevious 
   Else 
      iSearchDir = xlNext 
   End If 
   If Not (bFindRow) _ 
   Then 
      iSearchOdr = xlByColumns 
   Else 
      iSearchOdr = xlByRows 
   End If 
    
   With rngSearch 
      If (bLastOccurance) _ 
      Then 
         Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir) 
      Else 
         Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir) 
      End If 
   End With 
    
   If Cell Is Nothing Then 
      getItemLocation = 0 
   ElseIf Not (bFindRow) _ 
   Then 
      getItemLocation = Cell.Column 
   Else 
      getItemLocation = Cell.Row 
   End If 
   Set Cell = Nothing 

End Function

rizvisa1

Posts: 4479
Registration date: Thursday January 28, 2010
Status: Contributor
Last seen: May 5, 2022

769
May 31, 2011 at 06:20 PM

HI Suhas.
Ok first allow me vent off. A good representative of data is a helpful for any one trying to help. Based on your books, it seem that with in each group you may have blank rows. This information how the data is comes out drip drip, which is real frustrating and time wasting. First it was blank rows is a delimiter then it became that in column A only, there might be blank cells and yet they would still form the part of the group. and now your sample book that I was asking earlier seem to show that within each group you may have blank rows. Most, if not all people on any forum, not just this one, are just helping out of their own time for free. I understand that you most probably did not do intentionally it but please when you ask a question on any forum, please do provide as complete, and detailed and correct information as is possible It saves times and effort of any one who would be trying to help. Ok now that I have let off my pent up steam, here is your updated macro

Sub doSplitData()
     
  Dim lMaxRows                   As Long
  Dim sSheet                     As String
  Dim lStartRow                  As Long
  Dim lEndRow                    As Long
  Dim sFinalSheet                As String
  Dim lMaxCols                   As Integer
   
   sSheet = "Sheet1"
   Application.ScreenUpdating = False
   With Sheets(sSheet)
   
      lMaxCols = getItemLocation("*", .Cells, bFindRow:=False)
      lMaxRows = getItemLocation("*", .Cells)
       
      lStartRow = 0
      lStartRow = getItemLocation("*Start", .Range(.Cells(lStartRow + 1, 1), .Cells(lMaxRows, 1)), , False)
      Do While (lStartRow > 0)
         sFinalSheet = Trim(.Cells(lStartRow, 1))
         sFinalSheet = Left(sFinalSheet, Len(sFinalSheet) - Len("Start"))
         lEndRow = getItemLocation(sFinalSheet & "End", .Range(.Cells(lStartRow + 1, 1), .Cells(lMaxRows, 1)), , False)
         If (lEndRow = 0) Then lEndRow = lMaxRows
         Application.DisplayAlerts = False
         On Error Resume Next
         Sheets(sFinalSheet).Delete
         Err.Clear
         On Error GoTo 0
         Application.DisplayAlerts = True
         Sheets.Add
         ActiveSheet.Name = sFinalSheet
         Application.CutCopyMode = False
         .Range(.Cells(lStartRow + 1, 1), .Cells(lEndRow - 1, lMaxCols)).Copy
         With Sheets(sFinalSheet)
            .Cells(1, 1).PasteSpecial
            .Rows(1).Font.Bold = True
         End With
         Application.CutCopyMode = False
         lStartRow = getItemLocation("*Start", .Range(.Cells(lEndRow + 1, 1), .Cells(lMaxRows, 1)), , False)
      Loop
      Application.ScreenUpdating = True
   End With
End Sub

Public Function getItemLocation(sLookFor As String, _
                                rngSearch As Range, _
                                Optional bFullString As Boolean = True, _
                                Optional bLastOccurance As Boolean = True, _
                                Optional bFindRow As Boolean = True) As Long
    
   Dim Cell             As Range
   Dim iLookAt          As Integer
   Dim iSearchDir       As Integer
   Dim iSearchOdr       As Integer
    
   If (bFullString) _
   Then
      iLookAt = xlWhole
   Else
      iLookAt = xlPart
   End If
   If (bLastOccurance) _
   Then
      iSearchDir = xlPrevious
   Else
      iSearchDir = xlNext
   End If
   If Not (bFindRow) _
   Then
      iSearchOdr = xlByColumns
   Else
      iSearchOdr = xlByRows
   End If
    
   With rngSearch
      If (bLastOccurance) _
      Then
         Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
      Else
         Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
      End If
   End With
    
   If Cell Is Nothing Then
      getItemLocation = 0
   ElseIf Not (bFindRow) _
   Then
      getItemLocation = Cell.Column
   Else
      getItemLocation = Cell.Row
   End If
   Set Cell = Nothing

End Function

Subscribe To Our Newsletter!