Creating multiple workbooks from values in a single workbook

[Matt]

I think this question has been asked before but after searching, I cannot find what I am looking for.

I have a workbook and column B contains a list of staff members. Using VB, I want to create a seperate workbook for each staff member. To start with I have sorted the sheet by staff name and managed to copy the first staff's data to a new sheet but am not sure about looping through the rest of the staff. Any help would be appreciated.


thanks

Matt


' sort data by staff name

Cells.Select
Selection.Sort Key1:=Range("AM2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("AM1").Select

lastrow = Sheets("test01").Range("A65536").End(xlUp).Row
Set myrange = Range("AM3:AM" & lastrow)

For Each cell In myrange

' determine row address where staff name changes

If cell.Value <> cell.Offset(-1, 0).Value Then
cell.Offset(-1, 0).Select
replastrow = ActiveCell.Row

' copy and paste selection into new book and save book

Range("A2:AY" & replastrow).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs "C:" & Range("AM2").Value & " " & Format(Date, "yyyymmdd") & ".xls"

Exit For
End If

Next

 

[Andrew Poulsom]

Do you want the headings in row 2 and the data to be transferred?

 

[Matt]

Hi Andrew

I'm not too bothered about the headings, just the data would be great

thanks

Matt

 

[Andrew Poulsom]

Just to be sure:

1. What is in AM1, AM2 and AM3:End?

2. Is the file name always what is in AM2?

 

[Matt]

Row 1 is the header
Data starts in row 2 through to end

I used "AM3" as the start of myrange because when I used "AM2" the code stopped on the first line as the previous line is the header row.

Hope this shines some light on it

 

[Andrew Poulsom]

This seems to work:

Sub Test()
    Dim Rng As Range
    Dim c As Range
    Dim FirstRow As Long
    Dim LastRow As Long
    Dim Name As String
'   Sort data by staff name
    Cells.Select
    Selection.Sort Key1:=Range("AM2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Set Rng = Range("AM2:AM" & Range("A65536").End(xlUp).Row)
    FirstRow = 2
    LastRow = FirstRow
    For Each c In Rng
        If c.Value = c.Offset(1, 0).Value Then
            LastRow = c.Offset(1, 0).Row
        Else
            Name = Range("AM" & FirstRow).Value
            Range("A" & FirstRow & ":AY" & LastRow).Copy
            Workbooks.Add
            ActiveSheet.Paste
            ActiveWorkbook.SaveAs "C:" & Name & " " & Format(Date, "yyyymmdd") & ".xls"
            ActiveWorkbook.Close
            FirstRow = c.Offset(1, 0).Row
            LastRow = FirstRow
        End If
    Next c
End Sub

Note that, because you have C: without the backslash, the files will be saved in the current folder on drive C. It took me a while to find them!

 

[Matt]

Thanks Andrew, will give it a go in a second and let you know how I get on.

 

[Matt]

It has worked a treat

Thanks

Matt

 

[noppojp]

Hi,

i'd like to humbly ask for a modification to the above very clean code to do the following.

i have a workbook called ZRequest for Approval.xls that has 11 worksheets in it, that are all preformated with tons of conditional formatting, and email code in each to tell me that they've been saved, etc. Lots of goodies that need to be kept alive for every person.

Can i have the above code modified to make multiple copies of that workbook from a list of names that's in a wksht (separate wkbk) called NAMES.xls? The worksheet is also called NAMES. i can have the NAMES.xls open at the time, no worries about that. Basically following the same kind of logic as above.

i can change the names location to be AM2 for now. Can modify that later.

So far i've been doing this manually. Takes too much time to do manually, because i have more than 20 people now.

Thanks in advance!!

From Tokyo

 

[FinancialAnalystKid]

This seems to work:

Sub Test()
    Dim Rng As Range
    Dim c As Range
    Dim FirstRow As Long
    Dim LastRow As Long
    Dim Name As String
'   Sort data by staff name
    Cells.Select
    Selection.Sort Key1:=Range("AM2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Set Rng = Range("AM2:AM" & Range("A65536").End(xlUp).Row)
    FirstRow = 2
    LastRow = FirstRow
    For Each c In Rng
        If c.Value = c.Offset(1, 0).Value Then
            LastRow = c.Offset(1, 0).Row
        Else
            Name = Range("AM" & FirstRow).Value
            Range("A" & FirstRow & ":AY" & LastRow).Copy
            Workbooks.Add
            ActiveSheet.Paste
            ActiveWorkbook.SaveAs "C:" & Name & " " & Format(Date, "yyyymmdd") & ".xls"
            ActiveWorkbook.Close
            FirstRow = c.Offset(1, 0).Row
            LastRow = FirstRow
        End If
    Next c
End Sub

Note that, because you have C: without the backslash, the files will be saved in the current folder on drive C. It took me a while to find them!

I did a little modifications on this but can't seem to figure out how to add the row of titles into the new workbooks. My titles are in row 1.

Help is appreciated!