Macro to copy sheets and create individual files

rammergu

New Member
Joined
Oct 17, 2006
Messages
8
Hi,

I maintain a workbook with 11 worksheets in it (named Sheet1, sheet2, etc).Each sheet contains information that i have to email to individuals. Ex: sheet 1 to user A, sheet 2 to user B, etc.

Currently, i copy the sheet and paste it to a new workbook, save it, and then email to all the 11 users.

Can you help me with the macro, which automates this process. It should basically copy the sheet, create a new book, and the file name should be the same as the sheet name.

Thanks in advance.
 

Some videos you may like

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

agihcam

Well-known Member
Joined
Jan 16, 2006
Messages
1,624
Hi -
Welcome to the board.
try;
Code:
Sub TEST()
Dim NB, MB As Workbook
Set MB = ThisWorkbook
Dim I As Long
For I = 1 To Sheets.Count
    Set NB = Workbooks.Add
        ThisWorkbook.Sheets(I).Cells.Copy NB.Sheets(1).Range("A1")
        NB.SaveAs "C:\" & NB.Sheets(I).Name & ".XLS"
        NB.Close
Next
End Sub
 

rammergu

New Member
Joined
Oct 17, 2006
Messages
8
Thanks for the code. The code is working, however it not how exactly how i wanted it. I think i didnt explain very well,

there are 11 sheets, i go to each sheet tab, right click on it, click on 'move or copy', drop down and select '(new book)', check on 'copy'

A new work book is created with only one worksheet, retaining the name of the sheet and all the formatting.

Once this is done, i do a save as, and then close.
 

agihcam

Well-known Member
Joined
Jan 16, 2006
Messages
1,624
how about this one?
Code:
Sub TEST()
Dim NB, MB As Workbook
Set MB = ThisWorkbook
Dim I, II As Long
For I = 1 To MB.Sheets.Count
    Set NB = Workbooks.Add
        MB.Sheets(I).Cells.Copy NB.Sheets(1).Range("A1")
        NB.Sheets(1).Name = MB.Sheets(I).Name
        For II = 2 To NB.Sheets.Count
            Application.DisplayAlerts = False
            NB.Sheets(2).Delete
            Application.DisplayAlerts = True
        Next
        NB.SaveAs "C:\" & MB.Sheets(I).Name & ".XLS"
        NB.Close
Next
End Sub
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
75,919
Office Version
  1. 365
Platform
  1. Windows
Try this.
Code:
For Each ws In Worksheets
      ws.Copy
      Set wb = ActiveWorkbook
      wb.SaveAs ThisWorkbook.Path & "/" & ws.Name
      ' put code to email here
      wb.Close
Next ws
 

Watch MrExcel Video

Forum statistics

Threads
1,114,090
Messages
5,545,897
Members
410,711
Latest member
Josh324
Top