Copy Worksheet to a New Excel Document and SaveAs...

[Cinema]

Hi,

I have a Excel Workbook and want to copy a specific Worksheet to a new Workbook (.xlsx Format) and save it with a specific name.
The following macro function is triggered after clicking the save button. The new generated Excel Workbook should be replaced every time after clicking the save button.

Public Sub fkt_Copy()
    Dim str_Path_Dest As String
    Dim str_FileName As String
    Dim str_DestPathName As String
    Dim bFileExists, bFileOpen As Boolean
    Dim xApp As Excel.Application
    Dim xWbk As Workbook
    Dim ws As Worksheet
    Dim wb As Workbook
    Set wb = Workbooks("BasisDocument")
    bFileExists = False
    bFileOpen = False
   On Error GoTo 0
   str_Path_Dest = "C:\Documents\TEST\"
   str_FileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
   str_DestPathName = str_Path_Dest & "\" & str_FileName & ".xlsx"
   Set xWbk = Workbooks.Add
   xWbk.SaveAs filename = str_Path_Dest & str_FileName & ".xlsx"
    If Dir(str_DestPathName) <> "" Then
   bFileExists = True
   If Not IsFileOpen(str_DestPathName) Then
   bFileOpen = False
   End If
   End If
   If Not bFileOpen Or Not bFileExists Then
   Set xWbk = Workbooks.Add
   xWbk.SaveAs filename = str_Path_Dest & "str_FileName" & ".xlsx"
   If wb.Worksheets("Sheet1").FilterMode Then
   Worksheets("Sheet").ShowAllData
   End If
   wb.Worksheets("Sheet1").UsedRange.Copy
   xWbk.UsedRange.PasteSpecial xlPasteValue
    xWbk.SaveAs filename = str_Path_Dest & str_FileName, xlOpenXMLWorkbook
   xWbk.Close
   End If      
   Exit Sub
End Sub

This Code does not paste the Sheet to the new generated Excel workbook.

[Kenneth Hobs]

You should be able to adapt this to suit. Obviously, you just want the one sheet copied. You can pass the value of prefix to "". You can change the routine to save with a more custom name too if needed.

Sub Test_CopySheet()  
  Dim oSheet As Worksheet
  Dim prefix As String
  Dim thePath As String
  
  prefix = "Master_"
  thePath = ThisWorkbook.Path & "\"
  
  For Each oSheet In ThisWorkbook.Sheets
    CopySheet oSheet, thePath, prefix
  Next oSheet
End Sub


Sub CopySheet(sht As Worksheet, thePath As String, prefix As String)
    Dim wb As Workbook
    Set wb = Workbooks.Add(xlWBATWorksheet)
    sht.Copy after:=wb.Sheets(1)
    Application.DisplayAlerts = False
    wb.Sheets(1).Delete
    Application.DisplayAlerts = True
    wb.ActiveSheet.Name = sht.Name
    wb.SaveAs thePath & prefix & sht.Name & ".xlsx"
    wb.Close False
End Sub

[Cinema]

Hello Kenneth thank you for repyling. Unfortunately I have the error message for "CopySheet oSheet" in the first part of the code that the argumnt type byref is incompatible.

[Kenneth Hobs]

Did you use that code in Test or a modification?

There is a slight difference between Sheets and Worksheets.

For Each oSheet In ThisWorkbook.WorksSheets

[Cinema]

Hello Kenneth thank you very much