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:
- Split one excel sheet into multiple sheets based on column value
- Macro to split data into sheets - Best answers
- How to split one excel sheet into multiple sheets using macro - Best answers
- Mark sheet in excel - Guide
- Google sheet right to left - Guide
- How to open excel sheet in notepad++ - Guide
- Windows network commands cheat sheet - Guide
- How to screenshot excel sheet - 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