The below VBA code is intended to convert formulas in multiple worksheets to values, then save a copy of the workbook in the specified directory.
I'm trying to copy paste value only, but the workbook still saves with formulas in these sheets. I don't know what I did wrong,this code doesn't seem to work
Sub CREATE4SHEETS()
Sheets(Array("sheet1", "sheet3", "sheet6", "sheet7", "sheet8", "sheet10")).Select
Sheets("sheet10").Activate
Sheets(Array("sheet1", "sheet3", "sheet6", "sheet7", "sheet8", "sheet10")).Copy
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
ChDir "\\mac\desktop\" ' Name folder
ActiveWorkbook.SaveAs Filename:= _
"\\Mac\Desktp\newworkbook.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ' need to change the name of the folder
ActiveWorkbook.Save
End Sub
It seems that
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
is not working as supposed to. Does anyone know why? thanks!
The below modified code will convert any formulas in the indicated worksheets to values, then save the workbook with the specified filename.
Sub CREATE4SHEETS()
Dim WS as Worksheet
Application.DisplayAlerts = False
'For each WS in Sheets(Array("sheet1", "sheet3", "sheet6", "sheet7", "sheet8", "sheet10"))
' WS.UsedRange.Value2 = WS.UsedRange.Value2
'Next WS
For each WS in Worksheets
If (UBound(Filter(Array("sheet1", "sheet3", "sheet6", "sheet7", "sheet8", "sheet10"), WS.Name)) > -1) Then
'Keep this worksheet
WS.UsedRange.Value2 = WS.UsedRange.Value2
Else
WS.Delete
End If
Next WS
Set WS = Nothing
ActiveWorkbook.SaveAs Filename:= _
"\\Mac\Desktp\newworkbook.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ' need to change the name of the folder
Application.DisplayAlerts = True
End Sub
Related
I'm trying to write a VBA code to copy "Non-Blank" cells from one file to another. This code selects the last Non Blank row, but for the column it's copying A4 to AU. I'd like to copy columns A4 to LastcolumnNotblank and also last row. So basically copy A4 to (LastColumn)(LastRow)Not Blank
Would be really grateful if someone can help by editing the below code. Many thanks.
Sub Export_Template()
'' TPD
File_name = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")
If File_name <> False Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastRow
If Left(ActiveSheet.Range("A" & i).Value, 1) <> "" Then lastactiverow = i
Next i
'MsgBox (lastactiverow)
ActiveSheet.Range("A4:AU" & lastactiverow).Select
Selection.Copy
Set NewBook = Workbooks.Add
ActiveSheet.Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.SaveAs Filename:=File_name, FileFormat:=51
ActiveWorkbook.Close (False)
End If
End Sub
The code below will preserve your ActiveSheet range and use SaveAs to save to a new workbook with your specific name, without all the extra crap. It deletes all the sheets except for the ActivSheet, and deletes the first three rows, then using SaveAs to save to ThisWorkbook.Path. Your macro enabled workbook will not be changed.
I actually don't like to use ActiveSheet due to the obvious problems, but since you were using it i kept it. I would suggest you use the name of the worksheet.
Sub SaveActiveSheetRangeAsNewWorkbook()
Dim ws As Worksheet
Application.DisplayAlerts = False
With ThisWorkbook
For Each ws In Application.ThisWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name Then
ws.Delete
End If
Next
.Sheets(1).Range("A1:A3").EntireRow.Delete
.SaveAs Filename:="Engineering TPD", FileFormat:=xlOpenXMLWorkbook
End With
Application.DisplayAlerts = True
End Sub
I'm assuming that Col A is a good indicator of where to find your last used row
Also assuming that Row 1 is a good indicator of where to find your last used column
You need to change Sheet1 on 3rd line of code to the name of your sheet that has the data to be copied
You need to declare variables (Use Option Explicit)
Avoid .Select and .Selection at all costs (none are found in below solution)
You did not re-enable ScreenUpdating and DisplayAlerts
This is tested and works A-OK
Option Explicit
Sub Export_Template()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim NewBook As Workbook
Dim LRow As Long, LCol As Long
Dim FileName
FileName = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")
If FileName <> False Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set NewBook = Workbooks.Add
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
LCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
ws.Range(ws.Cells(4, 1), ws.Cells(LRow, LCol)).Copy
NewBook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
NewBook.SaveAs FileName:=FileName, FileFormat:=51
NewBook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End Sub
I just have started using vba.
Googled for a long time to find an answer.
I have written code for copying cells from one sheet into new one.
I have to do it for every file in a folder.
So I try to use looping. However in a middle of a process error occurs (subscript out of range)
Here is my code that works for one file.
Sub add()
Sheets.add.Name = "Good"
GetBook = ActiveWorkbook.Name
Sheets("Good").Range("A1") = GetBook
Sheets("Report Details").Range("E6:E8").Copy
With Sheets("Good").Range("B1")
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Sheet2.Activate
Range(Range("A1").End(xlDown), Range("H1").End(xlDown)).Copy
With Sheets("Good").Range("E1")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End Sub
Here I try to loop it but it doesn't work, problem occurs here in the first code when looping
With Sheets("Good").Range("E1")
Looping code
FolderPath = "C:\Users\Maxim Osipov\Documents\Mckinsey\BorisT\Project 3(Smart city solutions)\VBA collecting" 'change to suit
If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath + "\"
Filename = Dir(FolderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(FolderPath & Filename)
'Call a subroutine here to operate on the just-opened workbook
Call add
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
Try this slight variation:
Sub add()
'Sheets.add.Name = "Good"
Sheets("Good").Range("A1") = ActiveWorkbook.Name
Sheets("Report Details").Range("E6:E8").Copy
Sheets("Good").Range("B1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Sheets("Sheet2").Range(Range("A1").End(xlDown).Address, Range("H1").End(xlDown).Address).Copy
Sheets("Good").Range("E1").PasteSpecial Paste:=xlPasteValues
Sheets("Good").Range("E1").PasteSpecial Paste:=xlPasteFormats
End Sub
See also:
Microsoft : Range Object (Excel)
10 ways to reference Excel workbooks and sheets using VBA
MSDN : Refer to Sheets by Name
MSDN : How to Reference Cells and Ranges
MSDN : Range.Copy Method
I was having some trouble figuring out which workbook some of your sheets were in - the ones being opened, or the one being pasted to.
This code will loop through the xlsx files in your folder and copy the ranges to the workbook holding the VBA code.
I added a function to check if the Good worksheet already exists and use that if it does.
Public Sub Main()
Dim FolderPath As String
Dim FileName As String
Dim WB As Workbook
Dim WS As Worksheet
FolderPath = "C:\Users\Maxim Osipov\Documents\Mckinsey\BorisT\Project 3(Smart city solutions)\VBA collecting\"
FileName = Dir(FolderPath & "*.xls*")
Do While FileName <> ""
Set WB = Workbooks.Open(FolderPath & FileName, False, True) 'Not updating links & is read-only.
'You can't create two sheets with the same name,
'so check if it exists first.
If WorkSheetExists("Good") Then
Set WS = ThisWorkbook.Worksheets("Good")
Else
'Add a worksheet to the workbook holding this code.
Set WS = ThisWorkbook.Worksheets.Add
WS.Name = "Good"
End If
'Pass the workbook and worksheet references to the procedure.
Add WB, WS
WB.Close SaveChanges:=False
FileName = Dir
Loop
End Sub
Public Sub Add(WrkBk As Workbook, wrkSht As Worksheet)
Dim LastCell As Range
Dim LastRow As Long
With wrkSht
'Find the last cell.
'You could use "LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row"
'but not sure how much data is in the Sheet2.
Set LastCell = .Cells.Find("*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If LastCell Is Nothing Then
LastRow = 1
Else
LastRow = LastCell.Row + 1
End If
.Cells(LastRow, 1) = WrkBk.Name
WrkBk.Worksheets("Report Details").Range("E6:E8").Copy
.Cells(LastRow, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
With WrkBk.Worksheets(2)
.Range(.Cells(1, 1), .Cells(.Rows.Count, "H").End(xlUp)).Copy
End With
With .Cells(LastRow, "E")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End With
End Sub
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
If you can only use the Sheet2 reference in the workbook being opened this function will find it:
Public Function GetWorkSheet(sCodeName As String, Optional wrkBook As Workbook) As Worksheet
Dim wrkSht As Worksheet
If wrkBook Is Nothing Then
Set wrkBook = ThisWorkbook
End If
For Each wrkSht In wrkBook.Worksheets
If wrkSht.CodeName = sCodeName Then
Set GetWorkSheet = wrkSht
Exit For
End If
Next wrkSht
End Function
To use it just change this line at the bottom of the Add procedure:
With WrkBk.Worksheets(2)
to
With GetWorkSheet("Sheet2", WrkBk)
It's best practice (and warmly recommended) not to use Activate/ActiveXXX/Select/Selection pattern and take advantage of fully qualified range reference up to workbook one
so you could refactor your add() sub as follows (explanations in comments):
Option Explicit
Sub add(ws As Worksheet)
Dim repDetRngToCopy As Range, sht2RngToCopy As Range
With ws 'reference passed worksheet
Set repDetRngToCopy = .Parent.Worksheets("Report Details").Range("E6:E8") 'set needed range in "Report Details" worksheet of the same workbook the currently referenced sheet (i.e. the passed one) belongs to
With .Parent.Worksheets(2) 'reference Sheet2 worksheet of the same workbook the currently referenced sheet belongs to
Set sht2RngToCopy = .Range(Range("A1").End(xlDown), .Range("H1").End(xlDown)) 'set needed range in currently referenced sheet (i.e. Sheet2)
End With
'now start filling cells of referenced sheet (i.e. the passed one)
.Range("A1") = .Name
repDetRngToCopy.Copy 'copy from the range previously defined in "Report Details"
.Range("B1").PasteSpecial Paste:=xlPasteValues, Transpose:=True ' paste in currently referenced sheet
sht2RngToCopy.Copy 'copy from the range previously defined in Sheet2
.Range("E1").PasteSpecial Paste:=xlPasteValues + xlPasteFormats 'paste in currently referenced sheet
.Name = "Good" ' name currently referenced sheet
End With
End Sub
and consequently slightly change your "main" sub where you call it as follows:
Do While Filename <> ""
'Call a subroutine here to operate on the just-opened workbook
With Workbooks.Open(FolderPath & Filename) ' open and reference a new workbook
add .Sheets.add ' call add passing it a reference to a new sheet in referenced workbook (i.e. the newly opened one)
.Close True ' close referenced workbook saving changes
End With
Filename = Dir
Loop
I am having trouble saving one sheet from my workbook into a CSV file. I have 18 sheets in the one workbook. Every time I run the macro, it saves a different sheet. I also need it so the display alerts do not pop up. I am a beginner to VBA and running macros, so any help would be appreciated.
Sub csvfile()
'
' csvfile Macro
'
'
ChDir "C:\Users\RM\Documents"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\RM\Documents\Working_Program\PSSE_Export_Data.csv", FileFormat:= _
xlCSV, CreateBackup:=False
Application.DisplayAlerts = False
End Sub
This should do the trick, Just specify the sheet that you want to save in place of "Sheet1"
Sub csvfile()
Application.DisplayAlerts = False
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
ws.SaveAs Filename:= _
"C:\Users\RM\Documents\Working_Program\PSSE_Export_Data.csv", FileFormat:= _
xlCSV, CreateBackup:=False
End Sub
I have the following simple macro to copy data from a closed worksheet. The code runs fine from the VBA editor but fails with a subscript error when run from Excel via macro. The paste special statement appears to be the issue.
I just can't see where the problem is, can anyone help?
Dim wsMaster As Worksheet
Set wsMaster = Worksheets("Master Data")
Dim lastrow As Long
Dim Files As String
Files = "Download.xlsx"
Dim filepath As String
filepath = "C:\users\ms612533\desktop\"
Application.ScreenUpdating = False
wsMaster.Activate
Cells.Select
Selection.Clear
Workbooks.Open (filepath & Files)
lastrow = Worksheets("Global").UsedRange.Rows.Count
Worksheets("Global").Range("A1:V" & lastrow).Copy _
wsMaster.Range("B1")
Worksheets("Global").Range("CV1:cv" & lastrow).Copy
wsMaster.Range("a1").PasteSpecial (xlValues)**
Application.CutCopyMode = False
ThisWorkbook.Activate
Call CloseAll
Application.ScreenUpdating = True
End Sub
Sub CloseAll()
' Close all but the active workbook
Dim wkbk As Workbook
Application.ScreenUpdating = False
For Each wkbk In Application.Workbooks
If wkbk.Name <> ActiveWorkbook.Name Then
wkbk.Close SaveChanges:=False
End If
Next
Application.ScreenUpdating = True
End Sub
I think there's something wrong with the PasteSpecial line: when I use the macro recorder, I get something like this:
wsMaster.Range("a1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
I think we can ignore the parameters after the first. Then we have this:
wsMaster.Range("a1").PasteSpecial Paste:=xlPasteValues
Note that there are no parens (()) around the arguments: PasteSpecial doesn't return anything so it should be treated like a function. That's probably where the subscript issue is coming from.
Also notice the parameter, which comes from the xlPasteType enum, is a little different from the value you had.
The code appears to work fine when calling the macro from a button, but it doesn't work from a shortcut. I'll put it down to an Excel 'feature' and move on.
I am using the following function to save a worksheet from a workbook and save it to a separate workbook. However, it is saving the formulas, whereas I would rather just the values end up in the final workbook. How can I modify this so the resultant workbook doesn't contain formulae and just values?
Sub Sheet_SaveAs(FilePath As String, SheetToSave As Worksheet)
Dim wb As Workbook
Set wb = Workbooks.Add(xlWBATWorksheet)
With wb
SheetToSave.Copy After:=.Worksheets(.Worksheets.Count)
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
.SaveAs FilePath
.Close False
End With
End Sub
Using the link kindly provided I tried this, but to no avail:
Sub Sheet_SaveAs(FilePath As String, SheetToSave As Worksheet)
Dim wb As Workbook
Set wb = Workbooks.Add(xlWBATWorksheet)
With wb
SheetToSave.Copy After:=.Worksheets(.Worksheets.Count)
Application.DisplayAlerts = False
.Worksheets(1).Delete
.Worksheets(1).Copy
.Worksheets(1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.DisplayAlerts = True
.SaveAs FilePath
.Close False
End With
End Sub
but I get an error on the pastespecial line??
.Worksheets(1).Copy
This copies the sheet itself and does not relate to PasteSpecial. You could use:
.Worksheets(1).UsedRange.Copy
or similar. For example, Worksheets(1).Cells.Copy.
I assume it should be Worksheets(.Worksheets.Count) though.
In the following I am using SpecialCells to identify only the formulas in the worksheet, and setting rng.Value = rng.Value to convert these to the results of the formulas.
Sub Sheet_SaveAs(FilePath As String, SheetToSave As Worksheet)
Dim wb As Workbook
Dim ws As Worksheet
Dim rngFormulas As Range, rng As Range
Set wb = Workbooks.Add(xlWBATWorksheet)
With wb
SheetToSave.Copy After:=.Worksheets(.Worksheets.Count)
Set ws = .Worksheets(.Worksheets.Count)
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
With ws
Set rngFormulas = ws.Cells.SpecialCells(xlCellTypeFormulas)
For Each rng In rngFormulas
rng.Value = rng.Value
Next rng
End With
.SaveAs FilePath
.Close False
End With
End Sub
You will need to add some error handling code, to handle the case where there are no formulas in the copied worksheet. (Array formulas may also need to be accounted for.)
The easiest way to copy the values is to do it in 2 steps:
Copy the sheet, then replace the formulas with their values
After:
.Worksheets(1).Delete
in your original code, add the lines:
With Range(Worksheets(.Worksheets.Count).UsedRange.Address)
.Value = .Value
End With
The .value=.value is telling excel to replace every value with the value that is currently being displayed, so all formulas will be replaced with their calculated value
Sorry, answer was starting to look a complete mess, so deleted it and started again. I've written this - it appears to work fine when I tested it - you just need an extra line to save any resulting spreadsheet. :)
For Each Cell In ActiveSheet.UsedRange.Cells
Cell.Copy
Cell.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next