Copying Sheets to New Workbook and Save

[helpexcel]

Hi - I'm trying to copy sheets not named Sheet1/2/3 to a new workbook and then prompt the user to save it. This is the code I'm using.

Sub ExportFile()    
Application.ScreenUpdating = False


    Dim DstFile As String
    Dim TD As String
    TD = Format(Date, "mm-dd-yyyy")
    Dim wb As Workbook
    
    Set wb = Workbooks.Add
        
    Dim wks As Worksheet
       For Each wks In Worksheets
            If wks.Name <> "Sheet1" Or wks.Name <> "Sheet2" Or wks.Name <> "Sheet3" Then
            wks.Copy Before:=wb.Sheets(wb.Sheets.Count)
            End If
        Next
    
    DstFile = Application.GetSaveAsFilename _
    (InitialFileName:="New File" & "  " & TD & ".xls", _
    Title:="Save As")
    If DstFile = "False" Then
        MsgBox "File not Saved, Actions Cancelled."
        Exit Sub
    Else


        wb.Close
    End If


    MsgBox ("File Saved")
    


    Application.ScreenUpdating = True


End Sub

 

[Fluff]

How about

Sub helpexcel()
   Dim Ary As Variant
   Dim ws As Worksheet
   Dim i As Long
   
   ReDim Ary(1 To Sheets.Count - 3)
   For Each ws In Worksheets
      If ws.Name <> "Sheet1" And ws.Name <> "Sheet2" And ws.Name <> "Sheet3" Then
         i = i + 1
        Ary(i) = ws.Name
      End If
   Next ws
   Sheets(Ary).Copy
  
   ActiveWorkbook.SaveAs "New File" & "  " & Format(Date, "mm-dd-yyyy") & ".xls", 56
End Sub

 

[helpexcel]

You did it again, with much simpler code, THANKS!! 2 questions: 1. how do i stop the compatibility checker dialogue box from popping up? 2. How do I change it so the saves as box shows up and you can choose the location to save or cancel?

 

[Fluff]

Are you sure you want to save it as xls, rather than xlsx or xlsm?

 

[helpexcel]

I guess it doesn't matter, the checker pops up with both of those also. Also is there a way to delete the sheets from the original workbook after the new file is saved?

 

[Fluff]

In that case try

Sub helpexcel()
   Dim Ary As Variant, Fn As Variant
   Dim ws As Worksheet
   Dim i As Long
   Dim Fname As String
   
   ReDim Ary(1 To Sheets.Count - 3)
   For Each ws In Worksheets
      If ws.Name <> "Sheet1" And ws.Name <> "Sheet2" And ws.Name <> "Sheet3" Then
         i = i + 1
        Ary(i) = ws.Name
      End If
   Next ws
   Sheets(Ary).Move
   Fname = "New File" & "  " & Format(Date, "mm-dd-yyyy")
   Fn = Application.GetSaveAsFilename(Fname, , , "Save AS")
   If Fn = False Then Exit Sub
   ActiveWorkbook.SaveAs Fn & "xlsx", 51
End Sub

 

[helpexcel]

PERFECT! I need your brain Fluff!! thanks again!!!!!

 

[helpexcel]

this might be for another post, but this is the code i run to get the new worksheets. Would it be easier to combine it with your code above?

Sub ExtractData()

Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Sheet23.Columns("P") 
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(1, 1), Cells(lastrow, LastCol)).Sort Key1:=Cells(1, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To lastrow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
             ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A1")
            iStart = iEnd + 1
            Cells.Select
            Cells.EntireColumn.AutoFit
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True




End Sub

 

[Fluff]

You're welcome & thanks for the feedback