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

jatz007

New Member
Joined
Jun 8, 2020
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
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
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,975
Office Version
  1. 2010
Platform
  1. Windows
try this code:
VBA 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

New Member
Joined
Jun 8, 2020
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
try this code:
VBA 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

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
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

VBA Code:
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

Well-known Member
Joined
Dec 23, 2017
Messages
1,975
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

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

New Member
Joined
Jun 8, 2020
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
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

VBA Code:
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

New Member
Joined
Jun 8, 2020
Messages
5
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

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

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Jun 8, 2020
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
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.
VBA Code:
 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

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
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,)

VBA Code:
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
 

Forum statistics

Threads
1,140,999
Messages
5,703,642
Members
421,307
Latest member
morrden86

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top