Change the Folder in the code as required and the Name of the Summary Sheet.
The macro copies the 1st 3 header rows to the new worksheet and erach
department to a new workbook. It stores the workbook using the department
name and puts all the files into Folder specified in the code. The new
worksheet name is also the department name.

The code uses Autofilter to get each of the unique department names. It
creates in column IV the unique department names. Then the code sets the
autofilter to each department and copies the visible cells (on the filtered
items) starting in row 4 to the new workbook.


Sub Departments()

Folder = "c:\Temp\"
Set SourceSht = ThisWorkbook.Worksheets("Summary")

With SourceSht

LastRow = .Range("F" & Rows.Count).End(xlUp).Row
'get a unique list of departments and put in column IV
.Range("F4:F" & LastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), _
Unique:=True

'set autofilter
.Columns("F").AutoFilter

'Set header rows to copy
'don't include column IV with list of departments
Set HeaderRows = .Range("A1:IU3")

'set range of data to copy
'will only copy visible cells starting in row 4
'don't include column IV with list of departments
Set CopyRange = .Range("A4:IU" & LastRow)

'get row of last department row
LastDeptRow = .Range("IV" & Rows.Count).End(xlUp).Row
'the advance filter sometimes makes the 1st two
'items the same so skip the 1st item if it equals
'the 2nd
If .Range("IV1") = .Range("IV2") Then
StartRow = 2
Else
StartRow = 1
End If
For DepartmentRow = StartRow To LastDeptRow

'set autofilter to all
.Range("F1").AutoFilter _
field:=1, _
VisibleDropDown:=True

Department = .Range("IV" & DepartmentRow)
If Department < "" Then

'create new workbook with one worksheet
Set NewBk = Workbooks.Add(template:=xlWBATWorksheet)
Set NewSht = NewBk.Sheets(1)
'add department name to worksheet
NewSht.Name = Department

'set autofilter for each department
.Range("F1").AutoFilter _
field:=1, _
Criteria1:=Department, _
VisibleDropDown:=True

'copy header rows to new worksheet
HeaderRows.Copy Destination:=NewSht.Range("A1")
'Copy data to new sheet
CopyRange.SpecialCells(xlCellTypeVisible).Copy _
Destination:=NewSht.Range("A4")

'save new workbook in folder
NewBk.SaveAs Filename:=Folder & Department & ".xls"
NewBk.Close savechanges:=False
End If

Next DepartmentRow

'delete the list of departments
Columns("IV").Delete
End With

End Sub



"George" wrote:

Dear group members,

My need is to parse Excel file.
I have names of departments in F column:

aa
ab
ac
df
(et cetera, 30 departments)

I have list of departments and other information in my source Excel
file.
My task is:
1) copy three first lines of sheet "as is"
2) copy all strings with "aa" in F column,
3) paste to other Excel file and to save it as C:\destination\aa.xls

Then to do the same for "ab", "ac" and all the rest 30 departments.

Tell me please how do I perform this.
Thank you.