Create a new file from several sheets avoiding formulas and preserving formatting.

[jatz007]

Hello,
I have a workbook with 5 sheets: A,B,C,D,E. Sheet A has a cells where there are formulas (calculation of values from B and C sheets. Additionally, sheet A has a hyperlinks to a sheet D. There are also conditional formatting and number rounding format (in ones cells 0 decimals , in others 2). I wand to create a new workbook, where only sheets A and D are included in this new workbook. At the same time, as sheets B and C not include din the file, so in the sheet A numbers should be as values and preserving hyperlinks and conditional formatting/rounding formatting. I in the web I found the following VBA code, however it does not preserve conditional formatting and hyperlinks, What should I change in it?

Sub newfile()

Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim wb As Workbook
Dim sFileName As String, sPath As String


'Path to store new file
sPath = "LC:\XXX"
'Change filename as required
sFileName = "Expenses " & Format(Range("E1"), "Mmm yy")

'set the sheet you are copying. Change where neccessary
Set wsCopy = ThisWorkbook.Worksheets("A", "B")
Set wb = Workbooks.Add
Set wsPaste = wb.Sheets(1)

'Copy everything from copy sheet
wsCopy.Cells.Copy
'Paste Values only
wsPaste.Cells.PasteSpecial xlPasteValues
Application.CutCopyMode = False

'delete first row
wsPaste.Rows(1).Delete

'Save new workbook

wsPaste.Name = "Expenses" 'Change if needed
wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook

End Sub

 

[Vathana]

Another one to try. Run this Sub inside one of the modules of the original workbook!
Change the sheet names as well as the new file path and name.

Option Explicit

'Run this Sub from a module in the orginal workbook, replace sheet names

Sub TestCopySheet()

    Dim wb As Workbook, ws As Worksheet
    Dim sPath As String, sName As String
    
    'copy sheet 1 and 2 to new workbook and assign it to "wb"
    
    ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")).Copy
    
    Set wb = Application.ActiveWorkbook
    
    'replace formulas with values
    
    For Each ws In wb.Sheets
    
        ws.UsedRange.Value = ws.UsedRange.Value
    
    Next ws
    
    'save - create folder if does not exist
    
    sPath = "D:\Data\"
    sName = "NewWorkbook"
    
    If FileSystem.Dir(sPath) = "" Then FileSystem.MkDir (sPath)
    
    wb.SaveAs sPath & sName, xlOpenXMLWorkbook
    
End Sub