Copy sheet to new workbook with formating

[KreshBell]

Hi,
I have VB, which copies the sheet to the new workbook in the same folder, the name of the new file is the same as the source and an extension has been added, which is the name of the sheet I am copying. Everything works ok but I would like it to copy the format as well, and it doesn't work.

Can anyone help me?

Sub SheetCopyRename()


    Dim mySourceWB As Workbook
    Dim mySourceSheet As Worksheet
    Dim myDestWB As Workbook
    Dim myNewFileName As String
    
'   First capture current workbook and worksheet
    Set mySourceWB = ActiveWorkbook
    Set mySourceSheet = ActiveSheet


'   Build new file name based
    Filename = ActiveWorkbook.Name
    If InStr(Filename, ".") > 0 Then
    Filename = Left(Filename, InStr(Filename, ".") - 1)
    End If
    myNewFileName = mySourceWB.Path & "\" & Filename & "_" & mySourceSheet.Name & ".xlsx"


'   Add new workbook and save with name of sheet from other file
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:=myNewFileName
    Set myDestWB = ActiveWorkbook
    
'   Copy over sheet from previous file
    mySourceWB.Activate
    Cells.Copy
    myDestWB.Activate
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
'   Resave new workbook
    ActiveWorkbook.Save


End Sub

 

[earthworm]

Try below

Sub SheetCopyRename()


    Dim mySourceWB As Workbook
    Dim mySourceSheet As Worksheet
    Dim myDestWB As Workbook
    Dim myNewFileName As String
   
'   First capture current workbook and worksheet
    Set mySourceWB = ActiveWorkbook
    Set mySourceSheet = ActiveSheet


'   Build new file name based
    Filename = ActiveWorkbook.Name
    If InStr(Filename, ".") > 0 Then
    Filename = Left(Filename, InStr(Filename, ".") - 1)
    End If
    myNewFileName = mySourceWB.Path & "\" & Filename & "_" & mySourceSheet.Name & ".xlsx"


'   Add new workbook and save with name of sheet from other file
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:=myNewFileName
    Set myDestWB = ActiveWorkbook
   
'   Copy over sheet from previous file
    mySourceWB.Activate
    Cells.Copy
    myDestWB.Activate
    Range("A1").Select
   Selection.PasteSpecial Paste:=xlPasteValues  
    Selection.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
   
'   Resave new workbook
    ActiveWorkbook.Save


End Sub

 

[KreshBell]

to the left is the source, to the right is the copy. not copied formatting

 

[earthworm]

to the left is the source, to the right is the copy. not copied formatting

View attachment 55126

I think format is copied you are talking about colors ?

 

[KreshBell]

Row height is different, thumbnails are missing

 

[earthworm]

Row height is different, thumbnails are missing

You then need to specify that particular row . Secondly thumbnails are the object . May be someone else will be able to help you out in this.

 

[tonyyy]

*KreshBell,

Your original code worked for me, ie, it included colors, row heights and thumbnails. Clearly though it's not working for you. You might consider the following approach...

Sub SheetCopyRename()

Dim mySourceWB As Workbook
Dim mySourceSheet As Worksheet
Dim myNewFileName As String
Dim fName As String

'   First capture current workbook and worksheet
Set mySourceWB = ActiveWorkbook
Set mySourceSheet = ActiveSheet

'   Build new file name based
fName = ActiveWorkbook.Name
If InStr(fName, ".") > 0 Then fName = Left(fName, InStr(fName, ".") - 1)
myNewFileName = mySourceWB.Path & "\" & fName & "_" & mySourceSheet.Name & ".xlsx"

'   Copy over sheet from previous file
mySourceSheet.Copy
ActiveWorkbook.SaveAs FileName:=myNewFileName
End Sub

Cheers,

Tony