VBA: Copying data into new workbooks and saving the files

jenpwagner
jenpwagner used Ask the Experts™
on
(See attachment 1)

I am trying to write a Macro to automatically create and save a new unique workbook for each person on my spreadsheet.

For example, in MacroQuestion.xls, I would want to:
1. Select cells in A2 to C9  based on the fact Column A has the same name (Adam) from A2 to A9. I need the flexibility for the formula to automatically know to take all the new lines in case I add additional lines of expenses. IE: It will  not always be rows 2 to 9 that list Adam's expenses. It might be rows 3 to 50.
2. Copy A2 to C9 into a new workbook.
3. Automatically save the new workbook to the desktop as Adam.XLS.
4. Automatically make a separate file for the other people as well. So, running the Macro once would give me a "Adam.xls, Mark.xls, Jenny.xls, and Erin.xls" file.

Thank you for your help!

Erin
MacroQuestion.xls
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Try this.
Sub x()
 
Dim rng As Range, ws As Worksheet

Application.DisplayAlerts = False

With Sheet1
    Sheets.Add().Name = "temp"
    .Range("A1", .Range("A" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("temp").Range("A1"), Unique:=True
     For Each rng In Sheets("temp").Range("A2", Sheets("temp").Range("A2").End(xlDown))
        If UCase(Right(rng, 5)) <> "TOTAL" Then
            Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
            ws.Name = rng
            .AutoFilterMode = False
            .Range("A1").AutoFilter field:=1, Criteria1:=rng & "*"
            .AutoFilter.Range.Copy Sheets(rng.Text).Range("A1")
            Sheets(rng.Text).Move
            ActiveWorkbook.Close SaveChanges:=True, Filename:="C:\Users\Stephen\Desktop\" & rng & ".xls"
        End If
    Next rng
    .AutoFilterMode = False
    Sheets("temp").Delete
End With
     
Application.DisplayAlerts = True

End Sub

Open in new window

Expert of the Quarter 2010
Expert of the Year 2010

Commented:
Great code from Stephen!
I happen to run it on Excel 2007 and 2010 and the files that get generated give an error when opening due to being saved in Excel 2007 format, not matching the .xls extension.
So, just a few tweaks.

Credits to Stephen.
Sub x()
 
Dim rng As Range, ws As Worksheet, wb As Workbook, saveLocation As String
Set wb = ActiveWorkbook
saveLocation = "C:\temp\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With Sheet1
    Sheets.Add().Name = "temp"
    .Range("A1", .Range("A" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("temp").Range("A1"), Unique:=True
     For Each rng In Sheets("temp").Range("A2", Sheets("temp").Range("A2").End(xlDown))
        If UCase(Right(rng, 5)) <> "TOTAL" Then
            Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
            ws.Name = rng
            .AutoFilterMode = False
            .Range("A1").AutoFilter field:=1, Criteria1:=rng & "*"
            .AutoFilter.Range.Copy Sheets(rng.Text).Range("A1")
            Sheets(rng.Text).Move
' pre excel 2007
            If Val(Application.Version) < 12 Then
                ActiveWorkbook.SaveAs Filename:=saveLocation & rng & ".xls"
' excel 2007, but in compatibility mode
            ElseIf UCase(Right(wb.FullName, 4)) = ".XLS" Then
                ActiveWorkbook.SaveAs Filename:=saveLocation & rng & ".xls", FileFormat:=56
' excel 2007, leave extension to default
            Else
                ActiveWorkbook.SaveAs Filename:=saveLocation & rng
            End If
            ActiveWorkbook.Close
        End If
    Next rng
    .AutoFilterMode = False
    Sheets("temp").Delete
    .Select
End With
     
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Open in new window

Not sure why it did that, but try adding the middle line below.

Btw, thanks cyberwiki, and happy for your code to be credited too.
.AutoFilter.Range.Copy Sheets(rng.Text).Range("A1")
 ws.Range("C" & Rows.Count).End(xlUp).Formula = "=SUM(C2:C" & ws.Range("C" & Rows.Count).End(xlUp).Row - 1 & ")"
Sheets(rng.Text).Move

Open in new window

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial