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

 

[offthelip]

try this code:

Sub test2()

ActiveWorkbook.Sheets.Copy
Dim stname As String
Dim temp As String


stname = "B!"
For kk = 1 To 2
With Worksheets("A")
  lastrow = .UsedRange.Row + .UsedRange.Rows.Count - 1
  lastcol = .UsedRange.Column + .UsedRange.Columns.Count - 1
  inarr = Range(.Cells(1, 1), .Cells(lastrow, lastcol)).Formula
  For i = 1 To UBound(inarr, 1)
   For j = 1 To UBound(inarr, 2)
    temp = inarr(i, j)
    tt = InStr(temp, stname)
     If tt > 0 Then
     Range(.Cells(i, j), .Cells(i, j)).Value = Range(.Cells(i, j), .Cells(i, j)).Value
     End If
   Next j
  Next i
End With
stname = "C!"
Next kk



End Sub

I forgot to delete sheets B and C but this has changed all the formula to values for you.

 

[jatz007]

try this code:

Sub test2()

ActiveWorkbook.Sheets.Copy
Dim stname As String
Dim temp As String


stname = "B!"
For kk = 1 To 2
With Worksheets("A")
  lastrow = .UsedRange.Row + .UsedRange.Rows.Count - 1
  lastcol = .UsedRange.Column + .UsedRange.Columns.Count - 1
  inarr = Range(.Cells(1, 1), .Cells(lastrow, lastcol)).Formula
  For i = 1 To UBound(inarr, 1)
   For j = 1 To UBound(inarr, 2)
    temp = inarr(i, j)
    tt = InStr(temp, stname)
     If tt > 0 Then
     Range(.Cells(i, j), .Cells(i, j)).Value = Range(.Cells(i, j), .Cells(i, j)).Value
     End If
   Next j
  Next i
End With
stname = "C!"
Next kk



End Sub

I forgot to delete sheets B and C but this has changed all the formula to values for you.

Unfortunately, it did not help. It is strange that some rows are pasted as values, however others remain the same. May be this problem appeared because sometimes between numbers I have empty rows or empty column.

 

[Yongle]

Or another one for you to try
adapt it to your own needs
Amend the names of the sheets and the path the original and replacement workbook

Sub OpenWorkbookAndCopySomeSheets()
    Dim wb As Workbook, ws As Worksheet
    Const sh1 = "SheetA"
    Const sh2 = "SheetD"
'open and save the workbook under a new name
    On Error Resume Next
    Set wb = Workbooks.Open("C:\???\???\OriginalFileName.xlsx")
    wb.SaveAs ("c:\???\???\NewName.xlsx")
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
'copy and paste values in relevant sheets
    Sheets(sh1).UsedRange.Value = Sheets(sh1).UsedRange.Value
    Sheets(sh2).UsedRange.Value = Sheets(sh2).UsedRange.Value
    Application.DisplayAlerts = False
'delete unwanted sheets
    For Each ws In wb.Sheets
        Select Case ws.Name
            Case sh1, sh2:  'do nothing
            Case Else:      ws.Delete
        End Select
    Next ws
    Application.DisplayAlerts = True
    wb.Save
'and to close it
    wb.Close False
End Sub

 

[offthelip]

Unfortunately, it did not help. It is strange that some rows are pasted as values, however others remain the same. May be this problem appeared because sometimes between numbers I have empty rows or empty column.

If you want more help to solve the problem you must give me more detail. the code should only change formula to values where the formula references sheets B and C, the gaps between rows and columns shouldn't affect used range, but to check that;use debug to find out what values are in lastrow an lastcol, to see if that is the problem

 

[jatz007]

Or another one for you to try
adapt it to your own needs
Amend the names of the sheets and the path the original and replacement workbook

Sub OpenWorkbookAndCopySomeSheets()
    Dim wb As Workbook, ws As Worksheet
    Const sh1 = "SheetA"
    Const sh2 = "SheetD"
'open and save the workbook under a new name
    On Error Resume Next
    Set wb = Workbooks.Open("C:\???\???\OriginalFileName.xlsx")
    wb.SaveAs ("c:\???\???\NewName.xlsx")
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
'copy and paste values in relevant sheets
    Sheets(sh1).UsedRange.Value = Sheets(sh1).UsedRange.Value
    Sheets(sh2).UsedRange.Value = Sheets(sh2).UsedRange.Value
    Application.DisplayAlerts = False
'delete unwanted sheets
    For Each ws In wb.Sheets
        Select Case ws.Name
            Case sh1, sh2:  'do nothing
            Case Else:      ws.Delete
        End Select
    Next ws
    Application.DisplayAlerts = True
    wb.Save
'and to close it
    wb.Close False
End Sub

This also dos not help. When do this query I can see that the original workbook is failed ot save and no new file is produced.

 

[jatz007]

Unfortunately, it did not help. It is strange that some rows are pasted as values, however others remain the same. May be this problem appeared because sometimes between numbers I have empty rows or empty column.

Sorry, I made a mistake and wrong sheets are put in the query. Now it is working. Additionally in some rows I have formula =TODAY()-1 (and then take -1 from the consequent date) how also do for these rows.

 

[Yongle]

This also dos not help. When do this query I can see that the original workbook is failed ot save and no new file is produced.

The code I posted works - I tested it
If it is not saving there may be an error in the file path
Is the original file macro enabled?
Post amended code to see if I can help

 

[jatz007]

The code I posted works - I tested it
If it is not saving there may be an error in the file path
Is the original file macro enabled?
Post amended code to see if I can help

Here is amended code, path is okey.

 Dim wb As Workbook, ws As Worksheet
    Const sh1 = "Report"
    Const sh2 = "Metadata"
'open and save the workbook under a new name
    On Error Resume Next
    Set wb = Workbooks.Open("C:\path\file creation.xlsm")
    wb.SaveAs ("C:\path\NewName.xlsx")
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
'copy and paste values in relevant sheets
    Sheets(sh1).UsedRange.Value = Sheets(sh1).UsedRange.Value
    Sheets(sh2).UsedRange.Value = Sheets(sh2).UsedRange.Value
    Application.DisplayAlerts = False
'delete unwanted sheets
    For Each ws In wb.Sheets
        Select Case ws.Name
            Case sh1, sh2:  'do nothing
            Case Else:      ws.Delete
        End Select
    Next ws
    Application.DisplayAlerts = True
    wb.Save
'and to close it
    wb.Close False

 

[Yongle]

Path is okay but the file type is the problem
File type being changed from xlsm to xlsx
VBA must be told about the change of format

I have added a message box (in case it still causes a problem,)

Sub OpenWorkbookAndCopySomeSheets()
    Dim wb As Workbook, ws As Worksheet
    Const sh1 = "SheetA"
    Const sh2 = "SheetD"
'open and save the workbook under a new name
    On Error Resume Next
    Set wb = Workbooks.Open("C\:???\???\y.xlsm")
        Application.DisplayAlerts = False
        wb.SaveAs Filename:="c:\???\???\y.xlsx", FileFormat:=51
        Application.DisplayAlerts = True
    If Err.Number <> 0 Then
        MsgBox Err.Description
        GoTo TheEnd
    End If
    On Error GoTo 0
'copy and paste values in relevant sheets
    Sheets(sh1).UsedRange.Value = Sheets(sh1).UsedRange.Value
    Sheets(sh2).UsedRange.Value = Sheets(sh2).UsedRange.Value
'delete unwanted sheets
    Application.DisplayAlerts = False
    For Each ws In wb.Sheets
        Select Case ws.Name
            Case sh1, sh2:  'do nothing
            Case Else:      ws.Delete
        End Select
    Next ws
    Application.DisplayAlerts = True
    wb.Save
'and to close it
    wb.Close False
TheEnd:
On Error GoTo 0
End Sub