VBA Code takes too long to Run - vba

Please see the below VBA Code that I've came up with. Essentially, this is to open another workbook, Unmerge the Rows, Copy the Columns and Paste it into my Active Workbook. However after copy pasting, when the code runs to the CalculationAutomatic line, it takes around 15mins. Is there any other way to make it more efficient?
Thank you
Option Explicit
Sub ImportRemarks()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim PLPath As String
PLPath = Sheets("Instructions").Range("C16").Text
Dim wbThis As Workbook
Dim wbTarget As Workbook
Set wbThis = ActiveWorkbook
Set wbTarget = Workbooks.Open(PLPath)
wbTarget.Worksheets("Performance List").Select
Rows("1:2").Select
Selection.UnMerge
wbThis.Worksheets("keys").Range("I:I").Value =
wbTarget.Worksheets("Performance List").Range("F:F").Value
wbThis.Worksheets("keys").Range("J:L").Value =
wbTarget.Worksheets("Performance List").Range("P:R").Value
wbThis.Activate
Application.CutCopyMode = False
wbTarget.Close savechanges:=False
ActiveWorkbook.Sheets("Instructions").Select
Range("C22").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Maybe something like as follows for starters. Ideally, the optimization steps would go in their own subs. One to switch on optimization at the start and the other to return everything to how it was at the end (or on error).
As requested, this shows you how to remove the .Select parts of your code by using With statements. It also includes a safe exit, in case of error, to switch back on everything you disabled.
Option Explicit
Public Sub ImportRemarks()
Dim PLPath As String, wbThis As Workbook, wbTarget As Workbook
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo Errhand
Set wbThis = ThisWorkbook
Set wbTarget = Workbooks.Open(PLPath)
PLPath = wbThis.Worksheets("Instructions").Range("C16").Text
wbTarget.Worksheets("Performance List").Rows("1:2").UnMerge
With wbThis.Worksheets("keys")
.Range("I:I") = wbTarget.Worksheets("Performance List").Range("F:F")
.Range("J:L") = wbTarget.Worksheets("Performance List").Range("P:R")
End With
wbTarget.Close savechanges:=False
With wbThis
.Activate
' .Worksheets("Instructions").Range("C22").Activate '<=consider whether this is needed?
End With
Errhand:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
More info on optimization here:
https://www.thespreadsheetguru.com/blog/2015/2/25/best-way-to-improve-vba-macro-performance-and-prevent-slow-code-execution
http://www.cpearson.com/excel/optimize.htm

Related

Using Find and Resize to transpose values error

I am trying to take my current code, that uses a Find function to search for the value in cell "H4" (this value is in the worksheet where the code is) and find it in a second workbook searching from Columns A3-A100000 (Find functions start at the next row after the first, hence why in my code I have written A2:A100000 as my Find range). Once the value is found, I would like to transpose the resize values of the Find match in the second workbook (with an offset of 5 columns to start transposing values from column F ).
My code works but I am trying to further simplify my code and possibly speed it up by not declaring so many variables and eliminating stepping through so much code.
I currently have:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
Dim Key As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Not Intersect(Target, Range("E4:E5")) Is Nothing Then
Application.EnableEvents = False
Set sh1 = ThisWorkbook.Worksheets("Operator")
Set wb2 = Workbooks.Open(Filename:="\\schaeffler.com\stratford\DATA\NEA-FBA-P\Projects\SetupSheets\Databases\Database_IRR 200-2S.xlsm", Password:="123")
Set sh2 = wb2.Sheets("Changes")
Set Key = sh2.Range("A2:A100000").Find(sh1.Range("H4"), , xlValues, xlWhole)
sh1.Unprotect "123"
If Not Key Is Nothing Then
sh1.Range("N31").Resize(85).Value = Application.Transpose(Key.Offset(, 5).Resize(, 85).Value)
Else
sh1.Range("N31").Resize(85).ClearContents
End If
sh1.Protect "123"
wb2.Close False
End If
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I am trying to replace the above code with the following below, but it's producing the following error:
Run-time error '91': Object Variable or With block variable not set
Here is the code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Not Intersect(Target, Range("E4:E5")) Is Nothing Then
Application.EnableEvents = False
Sheet1.Unprotect "123"
Sheet1.Range("N31").Resize(85).Value = Application.Transpose(Workbooks.Open(Filename:=" \Databases\Database_IRR 200-2S.xlsm", Password:="123").Worksheets("Changes").Range("A2:A100000").Find(sh1.Range("H4"), , xlValues, xlWhole).Offset(, 5).Resize(, 85).Value)
Sheet1.Protect "123"
End If
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I have also posted this on another forum to get their opinion as well:
https://www.mrexcel.com/board/threads/using-find-and-resize-to-transpose-values-error.1140796/

Retain cutcopy mode after macro

So I have this problem which I can't wrap my head around.
I have a an excel report that executes an important macro on sheet_activate, and as we all know macros cancel CutCopyMode.
Therefore, if I want to copy & paste something from a different file into my report, it never works because as soon as I activate my report it runs the macro and cancels the CutCopyMode from the other file.
Things I have tried:
1) save cutcopymode value and re-activate it after the macro:
Dim tmpCT
tmpCT = Application.CutCopyMode
...
Application.CutCopyMode = tmpCT
the problem: it doesnt work.
2) save the data from the clipboard and re-insert it as plain text object after the macro is done running:
Dim DataClipBoard As String
Dim clipboardData As DataObject
Dim RangeCopied As Range
Set RangeCopied = Selection
DataClipBoard = ClipBoard_GetData
Application.CutCopyMode = False
...
Set clipboardData = New DataObject
With clipboardData
.SetText DataClipBoard
.PutInClipboard
End With
Set clipboardData = Nothing
The problem: it's plain text and doesn't retain formats/links/etc.
I'd appreciate any input you can give me on this issue.
The following macro will return the current range for Cut/Copy, which you can then store in a Range variable and re-Cut/Copy after your other workbook is open.
(Personally, I think that Application.CutCopyRange should be a built-in special variable to do this.)
Function CutCopyRange() As Range
Dim StoredMode As XlCutCopyMode
StoredMode = Application.CutCopyMode
If StoredMode < 1 Then Exit Function 'Null case
If StoredMode = xlCut Then
'Disappointing, since Clipboard lets you Paste a copy of a cut range...
MsgBox "Unfortunately, Worksheet.Paste(Link:=True) only works for Copy-mode.", vbCritical
Exit Sub
End If
Dim ScreenUpdating As Boolean, DisplayAlerts As Boolean, EnableEvents As Boolean
ScreenUpdating = Application.ScreenUpdating
DisplayAlerts = Application.DisplayAlerts
EnableEvents = Application.EnableEvents
Application.ScreenUpdating = False
Application.EnableEvents = False
'This makes us loose our Cut/Copy mode...
With Worksheets.Add
.Paste Link:=True
Set CutCopyRange = Range(Range(Replace(Selection.Cells(1, 1).Formula, "=", "")), _
Range(Replace(Selection.Cells(Selection.Rows.Count, Selection.Columns.Count).Formula, "=", "")))
Application.DisplayAlerts = False
.Delete
End With
'Restore Cut/Copy mode to what it was before the previous block
Select Case StoredMode
Case xlCut
CutCopyRange.Cut
Case xlCopy
CutCopyRange.Copy
End Select
Application.DisplayAlerts = DisplayAlerts
Application.ScreenUpdating = ScreenUpdating
Application.EnableEvents = EnableEvents
End Function

buttons not copying with sheet excel vba

I have some macros that copy my sheet in excel,and delete certain data. Unfortunately the buttons to which the macros are assigned do not copy over when the macros are run.
Sub CandD()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Shape, strtSh As Worksheet
Set strtSh = ActiveSheet
Sheets("BM Condition").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "BM Condition" & Sheets.Count - 1
Range("E14:E33,I14:I33,M14:M33").ClearContents
For Each sh In ActiveSheet.Shapes
sh.Delete
Next sh
strtSh.Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This is the macro I am using. I have very limited VBA experience and am not finding google very helpful. Could someone recommend a fix for my buttons not copying over?
EDIT: I forgot to mention that when manually copying the buttons remain. I am not sure why this is.
As FunThomas mentioned, I've tried and tested the following without any errors:
Sub CanD()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Shape, strtSh As Worksheet
Set strtSh = ActiveSheet
Sheets("BM Condition").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "BM Condition" & Sheets.Count - 1
Range("E14:E33,I14:I33,M14:M33").ClearContents
strtSh.Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

VBA Macro to copy and paste sheets into new workbook

I do a report every day in which I have to copy and paste several sheets into a new workbook titled Report (today's date).
In my report I have 4 sheets : Customers, Orders, Country, ID.
Customer and Country are a simple copy and paste from the master file, but Orders and ID are filtered data from one of my sheets in the master file. Orders is filtered to "Complete" and Id is everything except ID 200 and 500.
I tried building a macro based on this solution found here :
http://www.hivmr.com/db/ack717pc8f88jpdsf7838pcaspkcsdmd
The copy and paste works but I am unable to copy and paste multiple sheets/ rename sheets and filter the data.
Edit:
Sub CopyInNewWB()
'has been tested
Dim newWS, WS As Worksheet
Application.ScreenUpdating = False
Set WS = ThisWorkbook.Sheets("Sheet1")
Set newWS = Workbooks.Add.Sheets("Sheet1")
WS.Cells.Copy
newWS.Cells.PasteSpecial xlValues Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
No clue how your filtered sheets are set up, but this method will copy the sheets in your master exactly how they are currently filtered to a new workbook:
Sub CopyInNewWB()
Dim wbO As Workbook, wbN As Workbook
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set wbO = ActiveWorkbook
Set wbN = Workbooks.Add
wbO.Sheets("Customers").Copy wbN.Sheets(1)
wbO.Sheets("Orders").Copy wbN.Sheets(2)
wbO.Sheets("Country").Copy wbN.Sheets(3)
wbO.Sheets("ID").Copy wbN.Sheets(4)
wbN.Sheets("Sheet1").Delete
wbN.Sheets("Customers").Activate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

Excel crashes after I run this macro - blank error report

I am running this simple macro. The goal is to create new Data sheet on a click of a userform button (deleting the old one). After making a copy from a raw data sheet, it should rename it "Data". If sheet named "Data" already exists - delete it.
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet
Dim trigger As Integer
trigger = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To Sheets.Count
If Sheets(i).Name = "Data" Then
trigger = 1
Sheets("Data").Delete
Sheets("raw_Data").Visible = True
Set ws1 = Sheets("raw_Data")
ws1.Copy Sheets(Sheets.Count)
Sheets("raw_Data").Visible = False
End If
Next i
If trigger = 0 Then
Sheets("raw_Data").Visible = True
Set ws1 = ThisWorkbook.Worksheets("raw_Data")
ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
Sheets("raw_Data").Visible = False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Unload Me
ActiveSheet.Name = "Data"
End Sub
Am I running some kind of infinite loop here? If I delete:
ActiveSheet.Name = "Data"
Excel isn't crashing any more.
I am with Ron on this one. I made a little bit cleaner version of the code and maybe it will shed some light to what the problem is.
Option Explicit
Private Sub CommandButton1_Click()
Const strDATA_SHEET As String = "Data"
Const strDATA_RAW_SHEET As String = "raw_Data"
Dim shDataRaw As Worksheet
Call TurnExtrasOff
' Check if we have the sheet data if so then delete it
If DoesWorksheetExist(strDATA_SHEET, ThisWorkbook) Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets(strDATA_SHEET).Delete
Application.DisplayAlerts = True
End If
' Lets copy the raw data sheet.
Set shDataRaw = ThisWorkbook.Sheets(strDATA_RAW_SHEET)
shDataRaw.Visible = xlSheetVisible
shDataRaw.Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
' Rename the sheet and hide raw data
ActiveSheet.Name = strDATA_SHEET
shDataRaw.Visible = xlSheetHidden
Call TurnExtrasOn
' Unload the user form
Unload Me
End Sub
' Procedure to turn extra features on
Sub TurnExtrasOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
' Procedure to turn extra features oFF
Sub TurnExtrasOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationAutomatic
End With
End Sub
' Function to check if a sheet exists
Function DoesWorksheetExist(ByVal sheetname As String, aWorkbook As Workbook) As Boolean
On Error Resume Next
DoesWorksheetExist = (Not aWorkbook.Sheets(sheetname) Is Nothing)
On Error GoTo 0
End Function
I hope this helps