Copy Variable Named Worksheets to Single Files

[grady121]

As a Newbie I have inherited a file that, with the exeption of two named worksheets "Entry" & "Data" that I don't need, exports only specific named worksheet into a new workbook, with the new filename based on the existing worksheet name.

What I'm trying to acheive is for the code to export all worksheets (Not "Entry" & "Data") into a separate file as before, but regardless of sheetname. I am trying to add worksheets with variable named sheets so can't hard code.

Is it possible for someone to modify my existing code to achieve this.

Present code:
Sub SaveWorksheet_as_Workbook(SheetName As String, SavePath As String, SaveName As String)
Dim NewWorkbookName As String
Dim MasterWorkbook As String
Dim TempString As String
Dim P1Name As String

Application.ScreenUpdating = False
WorkbookName = ActiveWorkbook.Name
MasterWorkbook = WorkbookName

If SheetName = "Entry" Then
Exit Sub
ElseIf SheetName = "Data" Then
Exit Sub

ElseIf SheetName = "Monday" Then

Application.ScreenUpdating = False
P1Name = SaveName & "_" & "Monday"
WorkbookName = ActiveWorkbook.Name
Workbooks.Add xlWorksheet
Sheets("Sheet1").Name = P1Name
ActiveWindow.DisplayGridlines = False
Call SetPrint

ActiveWorkbook.SaveAs FileName:=SavePath & "\" & P1Name & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ScreenUpdating = False
Workbooks.Open FileName:=SavePath & "\" & P1Name & ".xls", UpdateLinks:=0
Windows(WorkbookName).Activate
Sheets("Monday").Select
Cells.Select
Selection.Copy
Windows(P1Name & ".xls").Activate
Cells.Select
ActiveSheet.Paste
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveWorkbook.Save
ActiveWorkbook.BreakLink Name:=SavePath & "\" & P1Name & ".xls", Type:= _
xlExcelLinks
ActiveWorkbook.Close
Range("C2").Select

ElseIf SheetName = "Tuesday" Then
etc

End Sub

Any help appreciated.

 

[Gary McMaster]

Here's a shot from the hip. It's tough to troubleshoot something this involved from afar.

In the procedure that calls "SaveWorksheet_as_Workbook" you could put something like the following. This would filter out the sheets you don't care about without cluttering your main proceedure with "If Thens".

Dim oSheet As Worksheet

For Each oSheet In ThisWorkbook
 
    Debug.Print oSheet.Name
 
    Select Case oSheet.Name
        Case "Entry"
            'Do nothing
        Case "Data"
            'Do nothing
        Case Else
            'Execute main proceedure for everything other than the two above named sheets.
             SaveWorksheet_as_Workbook oSheet.Name, SavePath, SaveName

    End Select

Next oSheet

The code you posted was already getting a "SheetName" from whatever it is that calls it.

Sub SaveWorksheet_as_Workbook(SheetName As String, SavePath As String, SaveName As String)

I'm not sure I spotted all the references to the target worksheet name in your code, but you will want to change all the hard coded references ("Monday" etc) to the variable "SheetName" (w/o quotes).

Here's the code you posted with some stuff commented out and a few comments added.

Dim NewWorkbookName As String
Dim MasterWorkbook As String
Dim TempString As String
Dim P1Name As String
 
Application.ScreenUpdating = False
WorkbookName = ActiveWorkbook.Name
MasterWorkbook = WorkbookName
 
'If SheetName = "Entry" Then
'Exit Sub
'ElseIf SheetName = "Data" Then
'Exit Sub
'ElseIf SheetName = "Monday" Then
 
Application.ScreenUpdating = False

'P1Name = SaveName & "_" & "Monday"
P1Name = SaveName & "_" & SheetName
 
WorkbookName = ActiveWorkbook.Name
Workbooks.Add xlWorksheet
 
Sheets("Sheet1").Name = P1Name ' Shouldn't this be just "SheetName" and not the entire "SaveName" ???? There is a limit on length of sheet names.
 
ActiveWindow.DisplayGridlines = False
Call SetPrint
ActiveWorkbook.SaveAs Filename:=SavePath & "\" & P1Name & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ScreenUpdating = False
Workbooks.Open Filename:=SavePath & "\" & P1Name & ".xls", UpdateLinks:=0
Windows(WorkbookName).Activate
 
'Sheets("Monday").Select
Sheets(SheetName).Select ' Name of the sheet passed into the 
proceedure ???
 
Cells.Select
Selection.Copy
Windows(P1Name & ".xls").Activate
Cells.Select
ActiveSheet.Paste
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveWorkbook.Save
ActiveWorkbook.BreakLink Name:=SavePath & "\" & P1Name & ".xls", Type:= _
xlExcelLinks
ActiveWorkbook.Close
Range("C2").Select
 
'ElseIf SheetName = "Tuesday" Then
'etc
 
End Sub

I hope this helps.

Gary