Excel Macro to copy a specific worksheet to another workbook - vba

this is my code for my Macro. What is does is copy a specific sheet to another workbook. My question is how to paste only values and the format must be read type only.
Sub NewReport()
Dim PRICE_REV_TEMPLATE As Workbook
Dim PRICE_REV_TEMPLATE_FC As Workbook
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set PRICE_REV_TEMPLATE = ActiveWorkbook
Set PRICE_REV_TEMPLATE_FC = Application.Workbooks.Add(1)
PRICE_REV_TEMPLATE.Sheets(Array(PRICE_REV_TEMPLATE.Sheets(6).Name)).Copy _
Before:=PRICE_REV_TEMPLATE_FC.Sheets(1)
PRICE_REV_TEMPLATE_FC.SaveAs FileName:="C:\Users\A3RBJZZ\Desktop\PRICE_REV_TEMPLATE_FC"
PRICE_REV_TEMPLATE_FC.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub


Try this - Hope this Helps
Sub NewReport()
Dim PRICE_REV_TEMPLATE As Workbook
Dim PRICE_REV_TEMPLATE_FC As Workbook
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set PRICE_REV_TEMPLATE = ActiveWorkbook
Set PRICE_REV_TEMPLATE_FC = Application.Workbooks.Add(1)
PRICE_REV_TEMPLATE.Sheets(Array(PRICE_REV_TEMPLATE.Sheets(1).Name)).Copy Before:=PRICE_REV_TEMPLATE_FC.Sheets(1)
'selecting all cells and pasting as only values
PRICE_REV_TEMPLATE_FC.ActiveSheet.Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
PRICE_REV_TEMPLATE_FC.ActiveSheet.Paste
Application.CutCopyMode = False
'Added the Readonlyrecommended attrib.
PRICE_REV_TEMPLATE_FC.SaveAs Filename:="C:\Users\A3RBJZZ\Desktop\PRICE_REV_TEMPLATE_FC", ReadOnlyRecommended:=True
PRICE_REV_TEMPLATE_FC.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub

Related

Union Error Message on Excel

I am getting an error message that says
run-time error 1004': method 'union' of object'_Global' failed
and it is pointing to the line Set unioned = Union(unioned, c)
any tips?
Option Explicit
Private Sub HideRows_Click()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayStatusBar = False
.EnableEvents = False
End With
'On Error Resume Next
Dim ws As Worksheet
For Each ws In Worksheets
Select Case ws.name
Case "Sheet1", "Sheet2", "Sheet3" 'sheets to exclude
'do nothing
Case Else 'hide rows on these sheets
Dim unioned As Range
Dim c As Range
For Each c In ws.Range("AJ16:AJ153,AJ157:AJ292")
If Len(c.Value2) = 0 Then
If unioned Is Nothing Then
Set unioned = c
Else
Set unioned = Union(unioned, c)
End If
End If
Next c
unioned.EntireRow.Hidden = True
End Select
Next ws
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayStatusBar = True
.EnableEvents = True
End With
End Sub

Improve performance with VBA Selection.AutoFill

I have code like the following:
Sub RMS()
Application.Calculation = xlCalculationManual
Sheets("m1").Range("A3").FormulaR1C1 = "=LEN(LEFT(m!R[2]C,FIND(""x"",m!R[2]C & "","")-1))"
Range("A1:A3").Select
Selection.AutoFill Destination:=Range("A1:EZ3"), Type:=xlFillDefault
Range("A1:EZ3").Select
Selection.AutoFill Destination:=Range("A1:EZ600"), Type:=xlFillDefault
Range("A1:EZ600").Select
End Sub
This code is running very slow. Is there any help you can give so that code like this could run much faster because I run this code in multiple sheets?

This will be faster :
Sub RMS()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With Sheets("m1")
.Range("A3").FormulaR1C1 = "=LEN(LEFT(m!R[2]C,FIND(""x"",m!R[2]C & "","")-1))"
.Range("A1:A3").AutoFill Destination:=.Range("A1:EZ3"), Type:=xlFillDefault
.Range("A1:EZ3").AutoFill Destination:=.Range("A1:EZ600"), Type:=xlFillDefault
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Excel 2013 and 2016 flicker when ScreenUpdating = False and creating a new hidden workbook

If you run the code below in Excel 2013 or Excel 2016 then it will cause Excel to flicker.
Does anyone have any suggestions on how to stop the flickering?
Sub FlickerTestMain()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
FlickerTestHelper
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Sub FlickerTestHelper()
Dim currentWorkbook As Workbook, newWorkbook As Workbook
Set currentWorkbook = Application.ActiveWorkbook
Set newWorkbook = Application.Workbooks.Add(xlWBATWorksheet)
newWorkbook.Windows(1).Visible = False
currentWorkbook.Activate
newWorkbook.Worksheets(1).Range("a1:Z10000").Value2 = "test"
newWorkbook.Close False
End Sub

Save a workbook with file path referenced in cell

What is the correct code in order for the workbook to save to the referenced file path in cell B19? The file path looks like this C:Desktop\ExcelFiles\Data Table.xlsb
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
ThisWorkbook.SaveAs Filename:=Sheets("Sheet1").Range("B19").Value
'^^^Need help understanding the correct syntax of this line ^^^

This worked for me.
Sub SaveMe()
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
ThisWorkbook.SaveAs Filename:=Sheets("Sheet1").Range("B19").Value, _
FileFormat:=xlExcel12, CreateBackup:=False
End Sub
Basically,just turn on the Macro Recorder and modify the code, slightly, to suit your needs.

Intermittent VBA macro error

I have written the below code to cycle through my worksheets as a kind of slideshow to use in a sales department. The code works perfectly when I step through in debug mode, however when I run the macro it only works intermittently, occasionally getting to the selecting of the worksheets without having reactivated the screen updating application function.
Here is the code I have created so far:
Sub Runshow()
Dim ws As Worksheet
On Error GoTo exit_
Application.EnableCancelKey = xlErrorHandler
For Each ws In ThisWorkbook.Worksheets
ws.Protect
Next
Application.DisplayFullScreen = True
Application.DisplayFormulaBar = False
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHorizontalScrollBar = False
ActiveWindow.DisplayVerticalScrollBar = False
Application.Calculation = xlManual
Let y = 0
Do Until y = 80
Application.ScreenUpdating = False
Workbooks.Open("c:\users\admin\downloads\crm.xlsx").Activate
Application.Calculate
ActiveWorkbook.Close savechanges = False
Application.ScreenUpdating = True
ThisWorkbook.Activate
Let x = 0
Do Until x = 23
For Each ws In ActiveWorkbook.Worksheets
ws.Select
Application.Wait (Now + TimeValue("00:00:10"))
x = x + 1
Next
Loop
y = y + 1
Loop
exit_:
For Each ws In ThisWorkbook.Worksheets
ws.Unprotect
Next
Application.DisplayFullScreen = False
Application.DisplayFormulaBar = True
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayGridlines = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
Application.Calculation = xlAutomatic
End Sub

I put together some simple code that does something similar, and works well. You can build out from here - ask any questions if there's anything you don't understand.
Sub Slideshow()
Dim ws As Worksheet
PrepareView True
For Each ws In ThisWorkbook.Worksheets
ws.Activate
Application.Wait (Now + TimeValue("00:00:10"))
Next ws
PrepareView False
End Sub
Function PrepareView(status As Boolean)
If status = True Then
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHorizontalScrollBar = False
ActiveWindow.DisplayVerticalScrollBar = False
ElseIf status = False Then
Application.DisplayFullScreen = False
Application.DisplayFormulaBar = True
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayGridlines = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
End If
End Function