Create workbook based on cell value change in column
 

I have a spreadsheet that has information for several different divisions on
one sheet. Column F specifies which division that row of information (DivE1,
DivW12, etc.). There are 3 to 6 rows of info for each division; 25 columns.

I need a macro that will run through the spreadsheet and pull out the rows
of information and create a new workbook for each division.

Is this possible?

Create workbook based on cell value change in column
 

the code does the following

1) Select folder to put results
2) Creates a new workbook and copies the header from from old book to new
book.
3) Make the new worksheet the division name
3) Starts with Row 2 (after header) in old wokbook and checks if column F is
different between two adjacent rows. Assume the old worksheet has been
sorted by row F.
4) Save the new work book using the division name as the workbook name.
5) Closes new workbook
6) continues until a blank cell if found in column F


Sub SaveDivisions()

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Select Folder ", &H1&)
If Not objFolder Is Nothing Then
Set oFolderItem = objFolder.Items.Item
Folder = oFolderItem.Path
If Right(Folder, 1) < "\" Then
Folder = Folder & "\"
End If

Set OldSht = ActiveSheet
With OldSht
'assume header row
RowCount = 2
Start = RowCount 'used to determine the rows with same division
Do While .Range("F" & RowCount) < ""
'test if division is the same in next row
If .Range("F" & RowCount) < .Range("F" & (RowCount + 1)) Then
Division = .Range("F" & RowCount)
'create new workbook with one sheet by copying a sheet and
'clear contents
OldSht.Copy
Set Newbk = ActiveWorkbook
Set NewSht = ActiveSheet
NewSht.Cells.ClearContents
NewSht.Name = Division

'copy header row
OldSht.Rows(1).Copy _
Destination:=NewSht.Rows(1)

'copy rows from old sheet to new sheet
OldSht.Rows(Start & ":" & RowCount).Copy _
Destination:=NewSht.Rows(2)

'save new book
Newbk.SaveAs Filename:=Folder & Division & ".xls"
'close book
Newbk.Close savechanges:=False

Start = RowCount + 1
End If
RowCount = RowCount + 1
Loop
End With
End If

End Sub


"Sherri" wrote:

I have a spreadsheet that has information for several different divisions on
one sheet. Column F specifies which division that row of information (DivE1,
DivW12, etc.). There are 3 to 6 rows of info for each division; 25 columns.

I need a macro that will run through the spreadsheet and pull out the rows
of information and create a new workbook for each division.

Is this possible?

Create workbook based on cell value change in column
 

Awesome!

Exactly what I needed. Works great! Thanks!

"joel" wrote:

the code does the following

1) Select folder to put results
2) Creates a new workbook and copies the header from from old book to new
book.
3) Make the new worksheet the division name
3) Starts with Row 2 (after header) in old wokbook and checks if column F is
different between two adjacent rows. Assume the old worksheet has been
sorted by row F.
4) Save the new work book using the division name as the workbook name.
5) Closes new workbook
6) continues until a blank cell if found in column F


Sub SaveDivisions()

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Select Folder ", &H1&)
If Not objFolder Is Nothing Then
Set oFolderItem = objFolder.Items.Item
Folder = oFolderItem.Path
If Right(Folder, 1) < "\" Then
Folder = Folder & "\"
End If

Set OldSht = ActiveSheet
With OldSht
'assume header row
RowCount = 2
Start = RowCount 'used to determine the rows with same division
Do While .Range("F" & RowCount) < ""
'test if division is the same in next row
If .Range("F" & RowCount) < .Range("F" & (RowCount + 1)) Then
Division = .Range("F" & RowCount)
'create new workbook with one sheet by copying a sheet and
'clear contents
OldSht.Copy
Set Newbk = ActiveWorkbook
Set NewSht = ActiveSheet
NewSht.Cells.ClearContents
NewSht.Name = Division

'copy header row
OldSht.Rows(1).Copy _
Destination:=NewSht.Rows(1)

'copy rows from old sheet to new sheet
OldSht.Rows(Start & ":" & RowCount).Copy _
Destination:=NewSht.Rows(2)

'save new book
Newbk.SaveAs Filename:=Folder & Division & ".xls"
'close book
Newbk.Close savechanges:=False

Start = RowCount + 1
End If
RowCount = RowCount + 1
Loop
End With
End If

End Sub


"Sherri" wrote:

I have a spreadsheet that has information for several different divisions on
one sheet. Column F specifies which division that row of information (DivE1,
DivW12, etc.). There are 3 to 6 rows of info for each division; 25 columns.

I need a macro that will run through the spreadsheet and pull out the rows
of information and create a new workbook for each division.

Is this possible?