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 without vba
- Split one excel sheet into multiple sheets based on column value vba - Best answers
- Split one excel sheet into multiple sheets based on column value - Best answers
- Number to words in excel without vba - Guide
- How to screenshot excel sheet - Guide
- How to enable vba in excel - Guide
- How to open excel sheet in notepad++ - Guide
- Transfer data from one excel worksheet to another automatically - 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