Snasui Excel Forum

Code: Select all

Sub SheetsToNewWorkbook()

   Dim oBaseWkBk    As Workbook
   Dim oNewWkBk     As Workbook
   Dim zSheets(5)   As String
   Dim zNewFileName As String
   Dim iCntr        As Integer
   
   zSheets(0) = "Add_New"
   
    
    Set oBaseWkBk = ActiveWorkbook
    Sheets("Add_New").Select
    zNewFileName = [C6].Value & Format([F7].Value) & ".xls"
    Set oNewWkBk = Workbooks.Add
    Application.DisplayAlerts = False
    oNewWkBk.SaveAs Filename:=zNewFileName, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    Application.DisplayAlerts = True
    
    
    For iCntr = 0 To UBound(zSheets) - 1
       oBaseWkBk.Activate
       Sheets(zSheets(iCntr)).Copy Before:=Workbooks(oNewWkBk.Name).Sheets("Sheet1")
       On Error GoTo NoCellsSelected
       Selection.SpecialCells(xlCellTypeFormulas, 23).Select
       With Selection
           .Copy
           .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                  SkipBlanks:=False, Transpose:=False
       End With  'Selection
       Application.CutCopyMode = False
NoCellsSelected:
       Resume Next
       On Error GoTo 0
    Next iCntr
    
    Application.DisplayAlerts = False
    oNewWkBk.Sheets("Sheet1").Delete
    Application.DisplayAlerts = True
  
End Sub

Code: Select all

    zSheets(0) = "Add_New"
    zSheets(1) = "Sheet1"
    zSheets(2) = "Sheet2"
    zSheets(3) = "Sheet3"
    zSheets(4) = "Sheet4"

Code: Select all

Sub SheetsToNewWorkbook()

   Dim oBaseWkBk    As Workbook
   Dim oNewWkBk     As Workbook
   Dim zSheets(5)   As String
   Dim zNewFileName As String
   Dim iCntr        As Integer
   
   zSheets(0) = "Home"
   
    
    Set oBaseWkBk = ActiveWorkbook
    Sheets("Home").Select
    zNewFileName = [C6].Value & Format([F7].Value) & ".xls"
    Set oNewWkBk = Workbooks.Add
    Application.DisplayAlerts = False
    oNewWkBk.SaveAs Filename:=zNewFileName, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    Application.DisplayAlerts = True
    
    
'    For iCntr = 0 To UBound(zSheets) - 1
       oBaseWkBk.Activate
       Sheets(zSheets(0)).Copy Before:=Workbooks(oNewWkBk.Name).Sheets("Sheet1")
       On Error GoTo NoCellsSelected
       Selection.SpecialCells(xlCellTypeFormulas, 23).Select
       With Selection
           .Copy
           .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                  SkipBlanks:=False, Transpose:=False
       End With  'Selection
       Application.CutCopyMode = False
NoCellsSelected:
       Resume Next
       On Error GoTo 0
'    Next iCntr
    
    Application.DisplayAlerts = False
    oNewWkBk.Sheets("Sheet1").Delete
    Application.DisplayAlerts = True
  
End Sub