I need to copy each worksheet into workbooks and saved in the specific path except 04 worksheets named NMS, MS, Master and Missing. Further, I need to copy the remaining 04 sheets named mentioned above into each workbook created with macro above.
and all worksheets must be protected with the same password.
The name of the new workbook will be the one of the sheet that is copied to it.
The new workbook is saved in the same folder as your starting file.
All worksheets that are password protected will remain so.
The empty sheet is deleted on code line 16. In English it's called "Sheet1". Don't know if you use an english version, otherwise you need to change the sheets reference.
Here is the code:
Sub RunMe()
Dim ws As Worksheet
Dim shName As String
For Each ws In Worksheets
If ws.Name <> "NMS" And ws.Name <> "MS" And _
ws.Name <> "Master" And ws.Name <> "Missing" Then
ws.Select
shName = ws.Name
Workbooks.Add
ThisWorkbook.ActiveSheet.Copy _
after:=ActiveWorkbook.Sheets(Sheets.Count)
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
ThisWorkbook.Sheets("NMS").Copy _
after:=ActiveWorkbook.Sheets(Sheets.Count)
ThisWorkbook.Sheets("MS").Copy _
after:=ActiveWorkbook.Sheets(Sheets.Count)
ThisWorkbook.Sheets("Master").Copy _
after:=ActiveWorkbook.Sheets(Sheets.Count)
ThisWorkbook.Sheets("Missing").Copy _
after:=ActiveWorkbook.Sheets(Sheets.Count)
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path _
& "\" & shName & ".xlsx"
ActiveWorkbook.Close
End If
Next ws
End Sub
Best regards,
Trowa
Monday, Tuesday and Thursday are usually the days I'll respond. Bear this in mind when awaiting a reply.
- Posts
- 138
- Registration date
- Thursday January 21, 2010
- Status
- Member
- Last seen
- May 8, 2019
6 -