I have a code that extracts a tab from a workbook and saves the tab as a separate sheet. Everything is working fine for me, except for the fact that the formulas are also extracted to the new sheet. How can I change the code mentioned below to save the sheet in the same format, but without any formulas?
Sub PrintFile2()
'check if folder exists
If Dir("C:\Excel Workpaper\", vbDirectory) = "" Then
MkDir "C:\Excel Workpaper\"
End If
'print to defined folder
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
Sheets("Calculations").Copy
Set wb = ActiveWorkbook
With wb
.SaveAs "C:\Excel Workpaper\ " & Range("B7").Text & " - Excel Workpaper",
FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = False
Application.ScreenUpdating = True
.Close False
End With
End Sub
Check this snippet, this code will change formula to values.
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Next sh
Related
i am stuck on the last part of the code below. Basically i need to filter my "wb" data from one workbook then paste it to a tab in a new workbook that i created. I am able to do everything except copy the filtered data into the new workbook tab. Any help would be appreciated. Also the data is dynamic, which is why i used "UsedRange". SaveAs paths have been edited for privacy.
Sub Save()
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = Workbooks.Add
ThisWorkbook.Sheets("Due_Date_Approaching").Copy Before:=wb.Sheets(1)
ThisWorkbook.Sheets("Overdue").Copy Before:=wb.Sheets(1)
wb.Sheets(2).Name = "Due Date Approaching"
Application.DisplayAlerts = False
wb.Sheets("Sheet1").Delete
wb.SaveAs "C:test1.xlsx"
Worksheets("Overdue").Activate
Worksheets("Overdue").Range("A1").AutoFilter Field:=35, Criteria1:="ASIA"
Worksheets("Overdue").UsedRange.Copy
Dim APAC As Workbook
Set APAC = Workbooks.Add
ActiveWorkbook.Worksheets.Add Count:=2
APAC.Sheets(1).Name = "Overdue"
APAC.Sheets(2).Name = "Due Date Approaching"
Application.DisplayAlerts = False
APAC.Sheets("Sheet1").Delete
APAC.SaveAs "C:Test2.xlsx"
'This is where it gives me "Object doesnt support this property or method"
Workbooks("Test2.xlsx").Worksheets("Overdue").Range("A1").Paste
Application.CutCopyMode = False
End Sub
It could be prettier, but functionally I think you missed the point to the links above. You most likely only want to copy the visible cells from your filter and you need not clear the clipboard before pasting. Using CurrentRegion as I did here assumes you are using continuous data. If not, it is better to declare the range using the last row and last column.
Here is a revision:
Sub Save()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Dim wb As Workbook
Set wb = Workbooks.Add
ThisWorkbook.Sheets("Due_Date_Approaching").Copy Before:=wb.Sheets(1)
ThisWorkbook.Sheets("Overdue").Copy Before:=wb.Sheets(1)
wb.Sheets(2).Name = "Due Date Approaching"
wb.Sheets("Sheet1").Delete
wb.SaveAs "C:test1.xlsx"
Dim APAC As Workbook
Set APAC = Workbooks.Add
ActiveWorkbook.Worksheets.Add Count:=2
APAC.Sheets(1).Name = "Overdue"
APAC.Sheets(2).Name = "Due Date Approaching"
APAC.Sheets("Sheet1").Delete
APAC.SaveAs "C:Test2.xlsx"
ThisWorkbook.Worksheets("Overdue").Range("A1").CurrentRegion.AutoFilter Field:=35, Criteria1:="ASIA"
ThisWorkbook.Worksheets("Overdue").Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Workbooks("Test2.xlsx").Worksheets("Overdue").Range("A1").PasteSpecial xlPasteAll
With Application
.CutCopyMode = False
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I've got a workbook where I am creating a button that allows to save two specific sheets without formula's (the purpose being that the sheets are going to be send to partners and costumers). I would like the sheets to be saved in a single document somewhere on my computer, and still have the current "design" with colors, setup etc.
I've currently written this code, which does everything that I've described, except deleting the formulas...
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Hope you can help :-)
I have a sheet I use something similar for, I'll adjust the code a bit to work with your scenario. If you don't want the settings to change, delete the TurnOnFunctions & TurnOffFunctions subs.
This code will only break the links, not necessarily all the formulas. So if a formula references another spreadsheet it will be a static value; however, if it is a simple formula that stays within the spreadsheet it will stay that way.
Also add your workbook name to the respective area.
Sub NewWorkbooks()
'This will make seperate workbooks for each of the tabs listed
Dim wb As Workbook
Dim NewBook As Workbook
Dim ws As Worksheet
Call TurnOffFunctions
Set wb = ActiveWorkbook
For Each ws In Workbooks("YOUR WORKBOOK NAMR"). _
Worksheets(Array("frontpage", "mobile"))
ws.Copy
Set NewBook = ActiveWorkbook
With NewBook
Call break_links(NewBook)
.SaveAs Filename:="C:XXXX" & "NAME", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
Next
Call TurnOnFunctions
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
Private Sub TurnOffFunctions()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
Private Sub TurnOnFunctions()
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
You can use yours too with this mod (untested):
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
Call break_links ActiveWorkbook
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
Hello and thank you for your time, in the function code below, how do I make it in a way that it will function on any users computer, not just mine.
I know I need to probably use the Environ("USERPROFILE") thing but I don't know how to incorporate it in the code below.
Function Import_Data() As Boolean
Dim x As Workbook
Dim targetWorkbook As Workbook
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Const F_PATH As String = "C:\Users\mohammad.reza\Desktop\MyFiles.xls"
'if no file then exit and return false
If Dir(F_PATH) = "" Then
MsgBox "My Files is not found on your Desktop"
Import_Data = False
Exit Function
End If
'If the file exists than load the file and continue
Import_Data = True
' This part delets all sheets except the summary tab
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
' This part will get the raw data from the downloaded file on the desktop
Set x = Workbooks.Open("C:\Users\mohammad.reza\Desktop\MyFiles.xls")
Set targetWorkbook = Application.ActiveWorkbook
' This part will copy the sheet into this workbook
With x.Sheets("MyFiles").UsedRange
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1").Resize( _
.Rows.Count, .Columns.Count) = .Value
End With
x.Close
' This part will rename the sheet and move it to the end
ActiveSheet.Name = "RAW DATA"
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Thank you brad for your answer, however when I use it, it gives the below error:
Try this ...
Function Import_Data() As Boolean
Dim x As Workbook
Dim targetWorkbook As Workbook
Dim xWs As Worksheet
Dim sPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sPath = Environ("USERPROFILE") & "\Desktop\MyFiles.xls"
'if no file then exit and return false
If Dir(sPath) = "" Then
MsgBox "My Files is not found on your Desktop"
Import_Data = False
Exit Function
End If
'If the file exists than load the file and continue
Import_Data = True
' This part delets all sheets except the summary tab
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
' This part will get the raw data from the downloaded file on the desktop
Set x = Workbooks.Open(sPath)
Set targetWorkbook = Application.ActiveWorkbook
' This part will copy the sheet into this workbook
With x.Sheets("MyFiles").UsedRange
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1").Resize( _
.Rows.Count, .Columns.Count) = .Value
End With
x.Close
' This part will rename the sheet and move it to the end
ActiveSheet.Name = "RAW DATA"
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
I am working on a VBA script to allow manipulation and export of a number of worksheets as csv files from an Excel workbook. I'd like to be able to export a list of specified sheets as csv files to a save location that is able to be selected, in addition any cell in a specific column that is blank but may contain a formula needs to be have the entire row deleted. The below script is what I currently have and it seems to work to a point but there are three main issues:
The line below will remove lines if the cell in column A is really blank i.e contains no formula, but does not work if formula is present: Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
The cycling through the sheets is untidy but functional, is there a way to use a list of named sheets to make the script more concise?
Ideally the save location would also be selectable from a choose file directory dialog box. Any suggestions on how to achieve this?
Many thanks in advance.
Sub createCSVfiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Declare and set variables
Dim wb1 As Workbook, ws1 As Worksheet
Dim wbname As String, i As Integer
Set wb1 = ThisWorkbook
'Cycle through sheets
For i = 1 To Worksheets.Count
wbname = Worksheets(i).Name
'Create Sheet1.csv
If InStr(1, (Worksheets(i).Name), "Sheet1", vbTextCompare) > 0 Then
Worksheets(i).Copy
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveWorkbook.SaveAs Filename:="C:\Users\forename.surname\Desktop\export\" & ActiveSheet.Name & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
wb1.Activate
End If
'Create Sheet2.csv
If InStr(1, (Worksheets(i).Name), "Sheet2", vbTextCompare) > 0 Then
Worksheets(i).Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\forename.surname\Desktop\export\" & ActiveSheet.Name & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
wb.Activate
End If
Next i
'Clean
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I think something like this is what you're looking for:
Sub createCSVfiles()
'Declare and set variables
Dim wb As Workbook
Dim ws As Worksheet
Dim wsTemp As Worksheet
Dim aSheets() As Variant
Dim vSheet As Variant
Dim sFilePath As String
Dim sNewFileName As String
Dim oShell As Object
Dim i As Long
'Select folder to save CSV files to
Set oShell = CreateObject("Shell.Application")
On Error Resume Next
sFilePath = oShell.BrowseForFolder(0, "Select folder to save csv files", 0).Self.Path & Application.PathSeparator
On Error GoTo 0
If Len(sFilePath) = 0 Then Exit Sub 'Pressed cancel
'Define sheet names here
aSheets = Array("Sheet1", "Sheet2")
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set wb = ThisWorkbook
'Cycle through sheets
For Each vSheet In aSheets
'Test if sheet exists
Set ws = Nothing
On Error Resume Next
Set ws = wb.Sheets(vSheet)
On Error GoTo 0
If Not ws Is Nothing Then
'Sheet exists
ws.Copy
Set wsTemp = ActiveSheet
'Remove rows with blanks in column A
With wsTemp.Range("A1", wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp))
.AutoFilter 1, "=", xlFilterValues
.Offset(1).EntireRow.Delete
.AutoFilter
End With
'Save and close
wsTemp.Parent.SaveAs sFilePath & wsTemp.Name & ".csv", xlCSV
wsTemp.Parent.Close False
End If
Next vSheet
'Clean
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
First line of code works fine, second errors out with a syntax error. I want it to do the same thing as first line except paste values only.
ThisWorkbook.Sheets(1).Range(Range("A4"), Range("A4").End(xlDown)).Copy .Sheets(1).Range("A1")
ThisWorkbook.Sheets(1).Range(Range("G4"), Range("G4").End(xlDown)).Copy .Sheets(1).Range("B1").PasteSpecial xlPasteValues
Full code for the sub
Private Sub CommandButton1_Click()
With Workbooks.Add
ThisWorkbook.Sheets(1).Range(Range("A4"), Range("A4").End(xlDown)).Copy .Sheets(1).Range("A1")
ThisWorkbook.Sheets(1).Range(Range("G4"), Range("G4").End(xlDown)).Copy .Sheets(1).Range("B1").PasteSpecial xlPasteValues
Application.DisplayAlerts = False
.SaveAs "C:\Users\my username\Desktop\Macro Demo\output.xlsx"
Application.DisplayAlerts = True
.Close
End With
End Sub
Range("A4") and Range("A4").End(xlDown) may not belong to ThisWorkbook.Sheets(1) and you cannot define a range using cells from another worksheet.
Private Sub CommandButton1_Click()
Dim nwb As Workbook
Set nwb = Workbooks.Add
With ThisWorkbook.Sheets(1)
.Range(.Range("A4"), .Range("A4").End(xlDown)).Copy _
Destination:=nwb.Sheets(1).Range("A1")
With .Range(.Range("G4"), .Range("G4").End(xlDown))
nwb.Sheets(1).Range("B1").Resize(.Rows.Count, 1) = .Value
End With
End With
With nwb
Application.DisplayAlerts = False
.SaveAs "C:\Users\my username\Desktop\Macro Demo\output.xlsx"
Application.DisplayAlerts = True
.Close
End With
End Sub