help for a vba code to copy Some sheets to another workbook

[Maxwolf]

well there is my case :

i would like to be able to copy all sheets EXCept this sheet name : Template, to another workbook. The user should be able to name the workbook where he want to copy the sheets and the directory where he want to copy the file.
.

thank you for your help

 

[Ajesh]

Try this:

Sub CopySheets()
Dim sWB As Workbook, dWB As Workbook
Dim FldrPicker As FileDialog
Dim wSht As Worksheet
Dim shtCount As Long
Dim fName As String

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Set sWB = ThisWorkbook

fName = Application.GetOpenFilename _
        (FileFilter:="Excel Files (*.xls*),*.xls*", _
        Title:="Select file to which you want to copy sheets...", _
        MultiSelect:=False)

If Len(fName) > 0 Then
    MsgBox "No file selected.", vbExclamation, "Sorry!"
    GoTo CleanExit
Else
    Set dWB = Workbooks.Open(fName)
    For Each wSht In sWB.Worksheets
        If wSht.Name <> "Template" Then
            wSht.Copy After:=dWB.Sheets(dWB.Sheets.Count)
            shtCount = shtCount + 1
        End If
    Next wSht
    If shtCount > 0 Then
        MsgBox shtCount & " Sheet(s) have been copied to " & dWB.Name, vbExclamation, "Sheets Copied..."
        dWB.Close SaveChanges:=True
    Else
        MsgBox "There were no sheets to copy.", vbExclamation, "No sheets to copy..."
        dWB.Close SaveChanges:=False
    End If
End If
CleanExit:
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

 

[Maxwolf]

thank you, it work if i change, first this code If Len(fName) > 0 Then must be replace by

If Len(fName) < 0 Then

this is asking me to open another workbook and then copy the sheets. but i do not have another workbook, the other worbook does not exist .

i want the code to ask the user to put a name for a new workbook and then only after that the sheets should be copied to the new workbook create by the user.

 

[Ajesh]

This should do the work:

Sub CopySheets()
Dim sWB As Workbook, dWB As Workbook
Dim wSht As Worksheet
Dim shtCount As Long
Dim fName As String

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Set sWB = ThisWorkbook

For Each wSht In sWB.Worksheets
    If wSht.Name <> "Template" Then
        If dWB Is Nothing Then
            wSht.Copy
            Set dWB = ActiveWorkbook
            shtCount = shtCount + 1
        Else
            wSht.Copy After:=dWB.Sheets(dWB.Sheets.Count)
            shtCount = shtCount + 1
        End If
    End If
Next wSht
   
If Not dWB Is Nothing Then
    fName = Application.GetSaveAsFilename _
        (InitialFileName:="", _
        FileFilter:="Excel Files (*.xlsx), *.xlsx", _
        Title:="Save New file As...")
        If fName = "False" Then
            MsgBox "File not Saved, Action Cancelled."
            dWB.Close SaveChanges:=False
            GoTo CleanExit
        Else
            dWB.SaveAs Filename:=fName, FileFormat:=51
            dWB.Close SaveChanges:=True
            MsgBox shtCount & " Sheet(s) have been copied to " & vbNewLine & _
            fName, vbExclamation, "Sheets Copied..."
        End If
Else
    MsgBox "There were no sheets to copy.", vbExclamation, "No sheets to copy..."
End If

CleanExit:
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub