Split data into multiple sheets using macro

Solved/Closed
Suhas - May 31, 2011 at 02:31 AM
rizvisa1 Posts 4478 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.
Related:

3 responses

rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
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
2