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:
- Macro to split data into sheets
- Split excel sheet into multiple sheets based on column value - Best answers
- How to split excel sheet into multiple worksheets based on rows - Best answers
- Sheets right to left - Guide
- How to reset safe folder password without losing data ✓ - Android Forum
- Tmobile data check - Guide
- Mint mobile data not working ✓ - Network Forum
- Gta 5 data download for pc - Download - Action and adventure
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