Como posso copiar cada planilha em uma nova pasta de trabalho e preservar a formatação

Question

Como no meu título .. Eu tenho o seguinte código:

Sub SaveSheets(yeard, monthd)
Dim strPath As String
Dim ws As Worksheet

Application.ScreenUpdating = False

strPath = ActiveWorkbook.Path & "\" & yeard & "\"
If Len(Dir(strPath, vbDirectory)) = 0 Then
    MkDir (strPath)
End If
strPath = ActiveWorkbook.Path & "\" & yeard & "\" & monthd & "\"
If Len(Dir(strPath, vbDirectory)) = 0 Then
    MkDir (strPath)
End If

For Each ws In ThisWorkbook.Sheets
    ws.Copy
    BreakLinks Workbooks(Workbooks.Count)
    Workbooks(Workbooks.Count).Close True, strPath & ws.Name & " DATASET " & monthd & " " & yeard & ".xlsx"
Next
Application.ScreenUpdating = True
End Sub
Sub BreakLinks(wb As Workbook)
    Dim lnk As Variant
    For Each lnk In wb.LinkSources(xlExcelLinks)
        wb.BreakLink lnk, xlLinkTypeExcelLinks
    Next
End Sub

Mas o problema é que a planilha está copiando sem preservar a formatação original. Existe uma maneira de manter esse código e adicionar algo extra para conseguir o que eu quero? Obrigado

    

Answer 1

Não tenho certeza de qual formatação não é preservada, mas copiei manualmente uma planilha para uma nova pasta de trabalho e a formatação foi copiada corretamente (seu código deve funcionar)

Ou você pode tentar o seguinte, que salva cada folha como um .xlsm separado:

Option Explicit

Public Sub saveWS()
    Dim ws As Worksheet

    For Each ws In Worksheets
        ws.SaveAs ws.Name, xlOpenXMLWorkbookMacroEnabled
    Next
End Sub

    

Answer 2

Em vez de criar uma nova pasta de trabalho e copiar cada folha nela, por que não apenas salvar a pasta de trabalho com um novo nome?