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
