Split data into multiple sheets using macro [Solved/Closed]
Suhas -
May 31, 2011 at 02:31 AM - Latest reply: rizvisa14481
Posts Thursday January 28, 2010Registration dateContributorStatus
January 6, 2016
Last seen
- May 31, 2011 at 09:31 PM
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.
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
Many thanks for the script. But since there are many blank rows later in my output I am not getting the desired results. Please could you help to modify the script in such a way that it will execute in below fashion.
There are 13 set of tables in the first sheet. Each one will have start and end indicator as below.
JVMStart
a b c d
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
JVMEnd
JDBCStart
e f g h
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5
JDBCEnd
JMSStart
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
JMSEnd
MonitorPolicyStart
...
...
...
MonitorPolicyEnd
WebContainerStart
...
...
...
WebContainerEnd
VirtualHostStart
...
...
...
VirtualHostEnd
AdminConsoleStart
...
...
...
AdminConsoleEnd
ClusterStart
...
...
...
ClusterEnd
NodeGroupStart
...
...
...
NodeGroupEnd
PMIStart
...
...
...
PMIEnd
IPFilteringStart
...
...
...
IPFilteringEnd
AppResourcesStart
...
...
...
AppResourcesEnd
SecurityStart
...
...
...
SecurityEnd
Now I want 13 sheets to be created with their respective names like below. i.e. copying all the rows after and before the JVMStart and JVMEnd and putting it into new sheet with the name JVM. Similarly for rest of the tables.
"JVM" # This will be the sheet name - just need to remove the start/end suffix and use the indicator as the name
a b c d
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
"JDBC"
e f g h
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5
"JMS"
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
What do you mean there are many blank rows later in your dataset. Unless there is a bug, the program is supposed to find first non-blank cell in column A. and then find the first blank cell that comes after this cell. Copies all the information into a new sheet and then starting from the one row down from the last row blank row that was found, again repeat. Basically get the group.
The script you gave is perfect. But in my data the later portion is having blank cells in column A which are part of a group and not supposed to be extracted individually. So I modified my script which pulls the data in such a way that for every group there will be a start and end indicator in column A. So all the rows within the indicators need to be pasted to a new sheet including the blank cells inbetween if any. Please help with the script for my requirements. Many thanks.
Could you please upload a sample EXCEL file WITH sample data, macro, formula , conditional formatting etc on some shared site like https://docs.google.com/,http://wikisend.com/ , http://www.editgrid.com/ etc
AND post back here the link to allow better understanding of how it is now and how you foresee. Based on the sample book, could you re-explain your problem too.
Note: your data need not be to be real data but a good representative of how data looks like
With the script u gave - the problem comes for me when data is like
a b c d
1 2 3 5
6 7 8 9
0 1 2 3
0 4 5 6
Now above, the 4th and 6th row is having blank cells but they are still the part of group/table with heading "a b c d". In this situation the macro creates separate sheet for the 5th and 7th row. So now I added a start and end indicator for each group. Like that there are 13 groups. Above eg will look like this with the indicators.
I am unable to upload sample excel now as it is in my office pc. Please could you write a new script based on below inputs.
There are 13 set of tables in the first sheet. Each one will have start and end indicator in column A as below.
JVMStart
a b c d
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
JVMEnd
JDBCStart
e f g h
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5
JDBCEnd
JMSStart
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
JMSEnd
MonitorPolicyStart
...
...
...
MonitorPolicyEnd
WebContainerStart
...
...
...
WebContainerEnd
VirtualHostStart
...
...
...
VirtualHostEnd
AdminConsoleStart
...
...
...
AdminConsoleEnd
ClusterStart
...
...
...
ClusterEnd
NodeGroupStart
...
...
...
NodeGroupEnd
PMIStart
...
...
...
PMIEnd
IPFilteringStart
...
...
...
IPFilteringEnd
AppResourcesStart
...
...
...
AppResourcesEnd
SecurityStart
...
...
...
SecurityEnd
Now I want 13 sheets to be created with their respective names like below. i.e. copying all the rows after and before the JVMStart and JVMEnd and putting it into new sheet with the name JVM. Similarly for rest of the tables.
"JVM" # This will be the sheet name - just need to remove the start/end suffix and use the indicator as the name
a b c d
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
"JDBC"
e f g h
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5
"JMS"
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
Based on your first example (original), this is a modifed script. In this case a set is marked by a complete blank row ( as opposed to column A in earlier solution). Rest hold true and still is valid
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
Dim lMaxCols As Integer
sSheet = "Sheet1"
sFinalSheet = "DataSheet"
iSheetCount = 0
Application.ScreenUpdating = False
With Sheets(sSheet)
lMaxCols = getItemLocation("*", .Cells, bFindRow:=False)
lMaxCols = lMaxCols + 1
lMaxRows = getItemLocation("*", .Cells)
With .Range(.Cells(1, lMaxCols), .Cells(lMaxRows, lMaxCols))
.NumberFormat = "General"
.FormulaR1C1 = "=IF(CountA(RC1:RC" & lMaxCols - 1 & ")>0,1,0)"
Application.CutCopyMode = False
.Copy
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
lStartRow = 0
lStartRow = getItemLocation(1, .Range(.Cells(lStartRow + 1, lMaxCols), .Cells(lMaxRows, lMaxCols)), , False)
Do While (lStartRow > 0)
lEndRow = getItemLocation(0, .Range(.Cells(lStartRow + 1, lMaxCols), .Cells(lMaxRows, lMaxCols)), , False)
If (lEndRow = 0) Then lEndRow = lMaxRows
iSheetCount = iSheetCount + 1
Application.DisplayAlerts = False
On Error Resume Next
Sheets(sFinalSheet & iSheetCount).Delete
Err.Clear
On Error GoTo 0
Application.DisplayAlerts = True
Sheets.Add
ActiveSheet.Name = sFinalSheet & iSheetCount
Application.CutCopyMode = False
.Range(.Cells(lStartRow, 1), .Cells(lEndRow, lMaxCols - 1)).Copy
With Sheets(sFinalSheet & iSheetCount)
.Cells(1, 1).PasteSpecial
.Rows(1).Font.Bold = True
End With
Application.CutCopyMode = False
lStartRow = getItemLocation(1, .Range(.Cells(lEndRow + 1, lMaxCols), .Cells(lMaxRows + 1, lMaxCols)), , False)
Loop
.Range(.Cells(1, lMaxCols), .Cells(lMaxRows, lMaxCols)).ClearContents
Application.ScreenUpdating = True
End With
End Sub
Public Function getItemLocation(sLookFor As String, _
rngSearch As Range, _
Optional bFullString As Boolean = True, _
Optional bLastOccurance As Boolean = True, _
Optional bFindRow As Boolean = True) As Long
Dim Cell As Range
Dim iLookAt As Integer
Dim iSearchDir As Integer
Dim iSearchOdr As Integer
If (bFullString) _
Then
iLookAt = xlWhole
Else
iLookAt = xlPart
End If
If (bLastOccurance) _
Then
iSearchDir = xlPrevious
Else
iSearchDir = xlNext
End If
If Not (bFindRow) _
Then
iSearchOdr = xlByColumns
Else
iSearchOdr = xlByRows
End If
With rngSearch
If (bLastOccurance) _
Then
Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
Else
Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
End If
End With
If Cell Is Nothing Then
getItemLocation = 0
ElseIf Not (bFindRow) _
Then
getItemLocation = Cell.Column
Else
getItemLocation = Cell.Row
End If
Set Cell = Nothing
End Function
No rizvisa. It is still not solving my problem. I do have multiple blank rows in the output which I dont want to use as seperator. That is why I dont want to use blank cells or blank rows as seperator and use the indicators instead. Please help. I want to scan the data using the exact 13 indicators/seperators I mentioned in my earlier response. This way I will have exact 13 sheets with accurate data.
Well sorry that it did not still solve your issue. I guess I will wait till you are able to post the workbook. Based on sample data it worked for me. Obviously some thing is not fitting right for you. Only way for me to know what would be to actually see a workbook with how it is now and how you would like to see. may be when you get home, you can post sample workbook. When you do post the book, post both version of data both with multiple blank row that you say are not handled properly by this code and the other one. As for me, multiple blank rows works perfectly fine as they are ignored. only rows with data are copied
Appreciate your time and efforts in solving my problem. I have uploaded both input and expected output xls sheets. Please download the same from below.
HI Suhas.
Ok first allow me vent off. A good representative of data is a helpful for any one trying to help. Based on your books, it seem that with in each group you may have blank rows. This information how the data is comes out drip drip, which is real frustrating and time wasting. First it was blank rows is a delimiter then it became that in column A only, there might be blank cells and yet they would still form the part of the group. and now your sample book that I was asking earlier seem to show that within each group you may have blank rows. Most, if not all people on any forum, not just this one, are just helping out of their own time for free. I understand that you most probably did not do intentionally it but please when you ask a question on any forum, please do provide as complete, and detailed and correct information as is possible It saves times and effort of any one who would be trying to help. Ok now that I have let off my pent up steam, here is your updated macro
Sub doSplitData()
Dim lMaxRows As Long
Dim sSheet As String
Dim lStartRow As Long
Dim lEndRow As Long
Dim sFinalSheet As String
Dim lMaxCols As Integer
sSheet = "Sheet1"
Application.ScreenUpdating = False
With Sheets(sSheet)
lMaxCols = getItemLocation("*", .Cells, bFindRow:=False)
lMaxRows = getItemLocation("*", .Cells)
lStartRow = 0
lStartRow = getItemLocation("*Start", .Range(.Cells(lStartRow + 1, 1), .Cells(lMaxRows, 1)), , False)
Do While (lStartRow > 0)
sFinalSheet = Trim(.Cells(lStartRow, 1))
sFinalSheet = Left(sFinalSheet, Len(sFinalSheet) - Len("Start"))
lEndRow = getItemLocation(sFinalSheet & "End", .Range(.Cells(lStartRow + 1, 1), .Cells(lMaxRows, 1)), , False)
If (lEndRow = 0) Then lEndRow = lMaxRows
Application.DisplayAlerts = False
On Error Resume Next
Sheets(sFinalSheet).Delete
Err.Clear
On Error GoTo 0
Application.DisplayAlerts = True
Sheets.Add
ActiveSheet.Name = sFinalSheet
Application.CutCopyMode = False
.Range(.Cells(lStartRow + 1, 1), .Cells(lEndRow - 1, lMaxCols)).Copy
With Sheets(sFinalSheet)
.Cells(1, 1).PasteSpecial
.Rows(1).Font.Bold = True
End With
Application.CutCopyMode = False
lStartRow = getItemLocation("*Start", .Range(.Cells(lEndRow + 1, 1), .Cells(lMaxRows, 1)), , False)
Loop
Application.ScreenUpdating = True
End With
End Sub
Public Function getItemLocation(sLookFor As String, _
rngSearch As Range, _
Optional bFullString As Boolean = True, _
Optional bLastOccurance As Boolean = True, _
Optional bFindRow As Boolean = True) As Long
Dim Cell As Range
Dim iLookAt As Integer
Dim iSearchDir As Integer
Dim iSearchOdr As Integer
If (bFullString) _
Then
iLookAt = xlWhole
Else
iLookAt = xlPart
End If
If (bLastOccurance) _
Then
iSearchDir = xlPrevious
Else
iSearchDir = xlNext
End If
If Not (bFindRow) _
Then
iSearchOdr = xlByColumns
Else
iSearchOdr = xlByRows
End If
With rngSearch
If (bLastOccurance) _
Then
Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
Else
Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
End If
End With
If Cell Is Nothing Then
getItemLocation = 0
ElseIf Not (bFindRow) _
Then
getItemLocation = Cell.Column
Else
getItemLocation = Cell.Row
End If
Set Cell = Nothing
End Function
has helped 1810 users this month