split data to different Excel files

[George]

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.

 

[Patrick Molloy]

paste this code into a standard module
i assume dept names start at F4, since rows 1-3 are being replicated?

Option Explicit
Sub moveCopy()
Dim text As String
Dim cells As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim rowindex As Long

Do While Range("F4") <> ""
text = Range("F4")
With ActiveSheet
Set cells = Columns(5).cells.Find(text)
Do While Not cells Is Nothing
If wb Is Nothing Then
Set wb = Workbooks.Add()
Set ws = wb.ActiveSheet
.Range("1:3").Copy
ws.Range("A1").PasteSpecial xlValues
rowindex = 4
End If

.Rows(cells.Row).Copy
ws.cells(rowindex, 1).PasteSpecial xlValues
rowindex = rowindex + 1
.Rows(cells.Row).Delete
Set cells = .cells.Find(text)
Loop
If Not wb Is Nothing Then
wb.SaveAs text
wb.Close False
Set wb = Nothing
Set ws = Nothing
End If
End With
Loop


End Sub

 

[Joel]

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

 

[Don Guillett]

Can't you just use data>filter>autofilter to work with it as is?

If you insist. As has been suggested by Joel, I would use advanced filter to
make a unique list>do a for each loop for each item in the unique list to
filter the sheet and then copy the visible to a new wb.

 

[Don Guillett]

I might do it this way.

Option Explicit
Sub MakeWorkbooksFromUniqueList()
Dim lr, lc, lclr As Long
Dim c As Range
Application.ScreenUpdating = False
lr = Cells.Find(What:="*", After:=[A1], _
SearchDirection:=xlPrevious).Row - 3
lc = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(4, "f").Resize(lr).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(1, lc + 1), Unique:=True
lclr = Cells(Rows.Count, lc + 1).End(xlUp).Row
On Error Resume Next
For Each c In Cells(2, lc + 1).Resize(lclr - 1)
With Range("a4").Resize(lr, lc)
..AutoFilter Field:=6, Criteria1:=c
Range("a1").Resize(lr, lc).SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add Template:="Workbook"
With Range("A1")
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteAll
.Select
End With
ActiveWorkbook.SaveAs Filename:=c
ActiveWorkbook.Close
.AutoFilter
End With
Next c
Columns(lc + 1).Clear
Application.ScreenUpdating = True
End Sub

 

[Ron de Bruin]

See
http://www.rondebruin.nl/copy5.htm