Question : VBA: Copying data into new workbooks and saving the files

(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

Attachments:

MacroQuestion.xls (31 KB) (File Type Details)

Attachment 1

Answer : VBA: Copying data into new workbooks and saving the files

Try this.

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:



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