Solved: How to create multiple files depending on column values

[PerS]

Hi

I have a spreadsheet with a lot of personal data retrieved from a database. From this spreadsheet I want to create (overwrite if they exists) x new spreadsheets containing only the rows for each department. The output files should be named ?Department3015.xls?, ?Department3030.xls? ect.

Input looks like this:

Dept Emp. Name
3015 2040 Gert Petersen
3015 2039 Bo Larsen
3030 0018 Allan Hansen
3020 EC21 Martino Lecca
3100 0020 Jesper Boysen
3042 2164 Kaj Mogensen
3018 EC52 Hans Nielsen
3042 2162 Hans Manscher
3020 2067 Anja Nielsen
3034 2144 Peter W?lke
3020 EC16 Henrik Madsen
0205 LENT Lene Thyk?r
3100 0001 Flemming Bjerring
3034 2146 Steen Frederiksen


Output (?Department3020.xls) looks like this:

Dept Emp Name
3020 EC21 Martino Lecca
3020 2067 Anja Nielsen
3020 EC16 Henrik Madsen


How do I solve this? I was thinking about using Autofilter in some way.

[mdmackillop]

Option Explicit
Sub MakeBooks()
Dim Rng As Range
Dim FiltRng As Range
Dim WB As Workbook
Dim Sh As Worksheet
Dim MyCol As Long, i As Long

MyCol = 8 '<== Change to suit
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Sh = ActiveSheet
Set Rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))

Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1,MyCol), Unique:=True
Set FiltRng = Range(Cells(2, MyCol), Cells(Rows.Count, MyCol).End(xlUp))
For i = 1 To FiltRng.Cells.Count
Set WB = Workbooks.Add

Sh.Columns("A:C").AutoFilter Field:=1, Criteria1:=FiltRng(i)
Sh.Range("A1:C" & Rng.Cells.Count).SpecialCells(xlCellTypeVisible).Copy WB.Sheets(1).Range("A1")
WB.SaveAs "C:\AAA\Department" & Format(FiltRng(i), "0000") & ".xls"
WB.Close
Set WB = Nothing
Next
Columns("A:C").AutoFilter
Columns(MyCol).ClearContents
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[Kenneth Hobs]

Nice routine mdmackillop.

If format is not an issue, an ADO routine might be a bit faster if you have alot of data to export like this.

If you just want the user to see their own data, you could let them open your xls directly. The Open event would then do this kind of thing as needed. I would use Application.User to define what user was opening the workbook which would then tell us which Department they could view.

Here is how I tweaked mdmackillop's code a bit.
'Add SpeedUp Module from, http://vbaexpress.com/kb/getarticle.php?kb_id=1035
Sub MakeBooks()
Dim Rng As Range
Dim FiltRng As Range
Dim WB As Workbook
Dim Sh As Worksheet
Dim MyCol As Long, i As Long
Dim dPath As String

dPath = ThisWorkbook.Path
If Dir(dPath, vbDirectory) = "" Then Exit Sub
dPath = dPath & "\" 'Dir should not be passed a folder path ending in "\".
On Error GoTo Cleanup
SpeedOn

MyCol = 8 '<== Change to suit
Set Sh = ActiveSheet
Set Rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))

Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1,MyCol), Unique:=True
Set FiltRng = Range(Cells(2, MyCol), Cells(Rows.Count, MyCol).End(xlUp))
For i = 1 To FiltRng.Cells.Count
Set WB = Workbooks.Add
Sh.Columns("A:C").AutoFilter Field:=1, Criteria1:=FiltRng(i)
Sh.Range("A1:C" & Rng.Cells.Count).SpecialCells(xlCellTypeVisible).Copy WB.Sheets(1).Range("A1")
WB.Worksheets(1).Columns("A:C").Autofit
WB.SaveAs dPath & "DepartMent" & Format(FiltRng(i), "0000") & ".xls"
WB.Close
Set WB = Nothing
Next

Cleanup:
Columns("A:C").AutoFilter
Columns(MyCol).ClearContents
SpeedOff
End Sub

[PerS]

Thank you both. It works perfect. Now I can create my 38 departementals files in seconds.:joy: