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
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - May 31, 2011 at 09:31 PM
Related:
- How to split excel sheet into multiple worksheets based on column value
- How to split excel sheet into multiple worksheets based on rows - Best answers
- Split one excel sheet into multiple sheets based on column value vba - Best answers
- Based on the value in cells b77 ✓ - Excel Forum
- How to screenshot excel sheet - Guide
- How to copy data from one excel sheet to another - Guide
- How to download multiple files from whatsapp web - WhatsApp Forum
- Google sheet right to left - Guide
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
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
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