I have a workbook with 6 sheets.
I want to save the values (not formulas) of the sheets 1 and 2 in 2 external files.
Tried this:
Worksheets("Sheet1").Copy
With ActiveWorkbook
.SaveAs Filename:="D:\sheet1.xls", FileFormat:=56, CreateBackup:=False
End With
Worksheets("Sheet2").Copy
With ActiveWorkbook
.SaveAs Filename:="D:\sheet2.xls", FileFormat:=56, CreateBackup:=False
End With
It Works. But:
It's saving the formulas, not its values.
If file exists, prompt a message asking if want to override
You would need to convert the formulas into values on your own. Do something like the following:
ThisWorkbook.Worksheets("Sheet1").Copy 'create a copy in a new workbook
Dim wb As Workbook
Set wb = ActiveWorkbook 'get the new workbook
'change formulas into values
wb.Worksheets(1).UsedRange.Value = wb.Worksheets(1).UsedRange.Value
'save
wb.SaveAs Filename:="D:\sheet1.xls", FileFormat:=56, CreateBackup:=False
'close it
wb.Close SaveChanges:=False
If you want to get rid of the overwriting question, check if the file D:\sheet1.xls alrady exists and kill it before you save it. I don't explain that in detail because there are already one million tutorials for that.
Improvement
Use a procedure to re-use your code:
Public Sub ExportWorksheet(ByVal SheetName As String, ByVal ExportToFile As String)
ThisWorkbook.Worksheets(SheetName).Copy
Dim wb As Workbook
Set wb = ActiveWorkbook
wb.Worksheets(1).UsedRange.Value = wb.Worksheets(1).UsedRange.Value
If Dir(ExportToFile) <> vbNullString Then Kill ExportToFile
wb.SaveAs Filename:=ExportToFile, FileFormat:=56, CreateBackup:=False
wb.Close SaveChanges:=False
End Sub
Sub TestIt()
ExportWorksheet SheetName:="Sheet1" ExportToFile:="D:\sheet1.xls"
ExportWorksheet SheetName:="Sheet2" ExportToFile:="D:\sheet2.xls"
End Sub
Note whenever you feel you would have to copy a code, split it apart into a seperate procedure to avoid redundancy.
A small example which may help: Option Explicit
Sub test()
Dim wsSou As Worksheet, wsDes As Worksheet
With ThisWorkbook
Set wsSou = .Worksheets("Sheet1")
Set wsDes = .Worksheets("Sheet2")
'Copy Paste - ONLY Values
wsSou.UsedRange.Copy
wsDes.Range("A1").PasteSpecial xlPasteValues
'Copy Paste - Values and Formattings
wsSou.UsedRange.Copy wsDes.Range("A1")
End With
End Sub
Related
I have an Excel-File in which the user can click on a button to save a version without formulas and only with values.
So far I use this VBA for it:
Sub Create_version_with_values_only()
Dim b As Worksheet
For Each b In Worksheets
b.Cells.Copy
b.Cells.Cells.PasteSpecial Paste:=xlPasteValues
Next b
Application.CutCopyMode = False
ActiveWorkbook.SaveCopyAs "G:\Folder\test.xlsm"
ThisWorkbook.Close SaveChanges:=False
End Sub
This VBA itself worsk fine.
However, the issue is that I have to close the file after the value-version of the file is created because the original version will not be available anymore.
Therefore, I am wondering if there is an alternative way to create the value-version of the file that makes it possible to go back to the original file afterwards.
Something like this:
Step 1) Change all formulas to values.
Step 2) Save the version with the values in the folder.
Step 3) Undo the value-replacements in original sheet without closing it.
Do you have any idea how to solve it?
There might be a more simple way to get there, but here's how you'd create a new workbook, transfer the values over and save.
Public Sub SaveValues()
Dim newWb As Workbook
Set newWb = Workbooks.Add 'create a new workbook for the values
Dim ws As Worksheet, newWs As Worksheet
For Each ws In ThisWorkbook.Worksheets
With newWb 'create worksheets and name them in new workbook
If ws.Index = 1 Then
Set newWs = .Worksheets(1)
Else
Set newWs = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
End If
newWs.Name = ws.Name
End With
With ws.UsedRange 'move values to new worksheet
newWs.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
Next
'save new workbook. If the current workbook is a .xlsb, change the .xlsm in the code below
newWb.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_hardcoded.xlsm"), xlOpenXMLWorkbookMacroEnabled
newWb.Close
End Sub
Updated for alternatives below:
Alternative
An alternative is to use ThisWorkbook.Worksheets.Copy to copying all worksheets in one go. Unfortunately, to use this code, we have to use ActiveWorkbook to make a reference to the new workbook. (I hoped it might return a Workbook or Worksheets object)
Public Sub SaveValues2()
Dim newWB As Workbook
ThisWorkbook.Worksheets.Copy
Set newWB = ActiveWorkbook 'not great practice
Dim ws As Worksheet
For Each ws In newWB.Worksheets
With ws.UsedRange 'hardcode values
.Value = .Value
End With
Next
newWB.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_hardcoded.xlsm"), xlOpenXMLWorkbookMacroEnabled
newWB.Close
End Sub
I want to update this code so it copies the values to a new workbook in csv format instead of sheet2 on same workbook. Thanks
Option Explicit
Dim TimeToRun
Sub chkTimer()
Application.DisplayAlerts = False
TimeToRun = Now + TimeValue("00:00:10")
Application.OnTime TimeToRun, "runMacro"
Application.DisplayAlerts = True
End Sub
Sub runMacro()
Calculate
Sheet1.Range("A1:D12").Copy
Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
chkTimer
End Sub
Sub stopMacro()
On Error Resume Next
Application.OnTime TimeToRun, "runMacro", , False
End Sub
Here is basic code to create a new workbook and transfer your range to Sheet1 in the new workbook, no copy/paste. It will save the new workbook, as an .xlsx file, to the same folder your macro enable workbook is located, using Thisworkbook.Path. Then name the new workbook "Test", change name as needed. Comments provided in the code.
Replace these two lines...
Sheet1.Range("A1:D12").Copy
Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
With...
Dim newWB As Workbook: Set newWB = Workbooks.Add 'create new workbook
With newWB
'You Don't need to Copy/Paste, use the equals method to get the values
.Sheets(1).Range("A1:D12").Value = ThisWorkbook.Sheets("Sheet1").Range("A1:D12").Value
'Save the new workbook to the same folder ThisWorkbook is located
.SaveAs Filename:=ThisWorkbook.Path & "\" & "Test" & ".xlsx", FileFormat:=51
End With
Thank you, this is easy and excellent. One issue though, when replaced with new code its trying to save a new Test workbook every 10 seconds instead of appending in one sheet. Also, could we create the destination workbook in .csv format? Appreciate your help.
Would appreciate if there's any help anywhere. Let's say, I have the following tabs: Data Set 001, Data Set 002, Data Set 003, so long the tab names contain Data Set, it should copy over to another workbook (let's say Main File). Any help with regards to this is welcomed. Thanks all in advance!
Best Regards,
Josh
I used this in Workbook containing worksheet, "ASSESSMENT FORMxx":
Sub CopyWorksheetsToNewWorkbook()
'This macro is to be in the ActiveWorkbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks.Add
wb.SaveAs Filename:="Book10" & ".xlsx"
Workbooks.Open ("Book10.xlsx")
For Each ws In Workbooks("ActiveWorkbookName.xlsm").Sheets
If ws.Name Like ("ASSESSMENT FORM*") Then ws.Copy Before:=Workbooks("Book10.xlsx").Worksheets("Sheet1")
Next ws
Workbooks("Book10.xlsx").Worksheets("Sheet1").Move Before:=Workbooks("Book10.xlsx").Sheets(1)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Note that both workbook with worksheet "ASSESSMENT FORMxx" and Book10.xlsx must be open.
Did you have a go at any code?
Sub Whatever()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks("AnyOpenWorkbookName.xlsx")
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "Data Set" & "*" Then
Call ws.Copy(after:=wb.Sheets(wb.Sheets.Count))
End If
Next ws
End Sub
You need to loop through all Worksheets of your 1st Workbook, test if its name contains Data set with Worksheet.Name and InStr.
If the InStr function returns something else than 0 (meaning your Worksheet name contains Data Set), you can copy the current Worksheet to the 2nd Workbook.
Adapt this sample to your needs:
'Loop through all worksheets
If InStr(wsCurrent.Name,"Data Set") <> 0 Then
' Copy wsCurrent to new WorkBook
End If
' End of loop
Hi I'm trying to write a macro to select certain worksheets into a new file.
the tricky part is that I want to save all worksheets but 3.
I've managed to select the worksheets but I can't find how to create a new workbook and then save it.
here's my code, the sub stops at Sheets(Array(Selection)).Copy
which is not the correct command.
thanks for you help
Sub ExportPrices()
Dim ExportName As String
Dim ReportingDir As String
Dim Dashboard As String
Dim ws As Worksheet
Dashboard = ThisWorkbook.Name
ExportName = Workbooks(Dashboard).Worksheets("Macro").Range("ExportName").Value
ReportingDir = Workbooks(Dashboard).Worksheets("Macro").Range("ReportingDir").Value
Workbooks(Dashboard).Worksheets("Europe").Select
For Each ws In Worksheets
If ws.Name <> "Macro" And ws.Name <> "Dashboard" And ws.Name <> "Data" Then
ws.Select (False)
End If
Next
'create an array from selection
Sheets(Array(Selection)).Copy
ActiveWorkbook.SaveAs Filename:=ReportingDir & ExportName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
You must add new workbook and copy target sheet to wb:
Dim oOutBook As Workbook
Set oOutBook = Workbooks.Add
Sheets(Array(Selection)).Copy Before:=oOutBook.Sheets(1)
oOutBook.SaveAs strPathOutput
You can use the .Move method in VBA. When not presented with a location to move to, the .Move method will move the specified sheet into a new workbook.
Sheets("Yoursheet").Move
As this will always be the latest created workbook, you can then refer to this by using Workbooks.Count:
Dim wb As Workbook
Set wb = Workbooks(Workbooks.Count)
Related: Save each sheet in a workbook to separate CSV files
I’ve inherited some code that I’m trying to update. The intention is to take a particular range from each of certain (macro-generated) sheets and save them as distinct CSV files. Here’s the existing code, somewhat simplified & with error checking removed:
' Save sheets not named "Table" as CSV files
Sub Extract_CSV()
Dim CurrentSheet As Integer
For CurrentSheet = 1 To ActiveWorkbook.Worksheets.Count
ActiveWorkbook.Worksheets(CurrentSheet).Activate
With ActiveWorkbook.Worksheets(CurrentSheet)
If (.Name <> "Table") Then
.Range("J3:J322").Select
.SaveAs Filename:=ActiveSheet.Name, FileFormat:=xlCSV, CreateBackup:=True
End If
End With
Next CurrentSheet
End Sub
The line .Range("J3:J322").Select is a noop in this context, but how can I achieve what this was trying to do: save only the range J3:J322 to this new CSV file?
I've augmented your code and added comments. This code creates a temporary workbook to copy/paste your selection and save it. The temporary workbook is then closed. Note that this code will overwrite existing files without prompts. If you wish to see prompts, then remove the Application.DisplayAlerts lines before and after the loop.
Sub Extract_CSV()
Dim wb As Workbook
Dim CurrentSheet As Integer
For CurrentSheet = 1 To ActiveWorkbook.Worksheets.Count
ActiveWorkbook.Worksheets(CurrentSheet).Activate
'Suppress Alerts so the user isn't prompted to Save or Replace the file
Application.DisplayAlerts = False
With ActiveWorkbook.Worksheets(CurrentSheet)
If (.Name <> "Table") Then
'Select the range and copy it to the clipboard
.Range("J3:J322").Select
Selection.Copy
'Create a temporary workbook and paste the selection into it
Set wb = Application.Workbooks.Add
wb.Worksheets(1).Paste
'Save the temporary workbook with the name of the the sheet as a CSV
wb.SaveAs Filename:=ActiveSheet.Name, FileFormat:=xlCSV, CreateBackup:=True
'Close the workbook
wb.Close
End If
End With
'Restore alerts
Application.DisplayAlerts = True
Next CurrentSheet
End Sub
You may copy the target range, paste it in a new worksheet (you may need to paste as values, and paste number format as well), and then save that worksheet.
The code below embodies the idea. Lines commented with '* are added/modified as compared to your code. A few things to bear in mind:
By pasting values, you prevent the (unlikely) case of having cells with functions whose evaluated value changes upon pasting in the newly created workbook.
Using rng instead of selecting the Range is the recommended practice. If you do not have a lot of these operations, you would likely not notice the (minor) time saving.
Disabling DisplayAlerts eliminates alerts during macro execution (please see this to find out if you would like to make adjustments).
' Save sheets not named "Table" as CSV files
Sub Extract_CSV()
Dim CurrentSheet As Integer
For CurrentSheet = 1 To ActiveWorkbook.Worksheets.Count
ActiveWorkbook.Worksheets(CurrentSheet).Activate
Application.DisplayAlerts = False '*
With ActiveWorkbook.Worksheets(CurrentSheet)
If (.Name <> "Table") Then
'.Range("J3:J322").Select
Dim rng As Range '*
Set rng = .Range("J3:J322") '*
rng.Copy '*
Dim wb As Workbook '*
Set wb = Application.Workbooks.Add '*
wb.Worksheets(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False '*
wb.SaveAs Filename:=ActiveSheet.Name, FileFormat:=xlCSV, CreateBackup:=True '*
wb.Close '*
End If
End With
Application.DisplayAlerts = True '*
Next CurrentSheet
End Sub