Please advise on the following:
I have a code that should refresh formulas in my workbook and then copy the results as values to the other sheet. The problem is that the code flies right through everything and copies data even before the refresh is completed (refresh takes approx. 10-15 seconds).
I have used the below (and its varieties) but it didn't do anything to slow it down:
Application.Wait (Now + TimeValue("0:00:15"))
Do I have to do a loop that would check the cell content and execute "copy" part once it identifies the cell is updated?
Sub Excel_VBA_Timer_Event1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim V As Workbook: Dim x, y, z As Worksheet
Set V = ThisWorkbook: Set x = V.Sheets(1): Set y = V.Sheets(2): Set z = V.Sheets(3)
z.Columns("A:O").EntireColumn.Delete
Aplication.Run "RefreshAllWorkbooks"
'WAIT HERE for approx 15 seonds
'At the moment the code flies through till the end before Bloomberg formulas are refreshed
y.Columns("C:M").Copy
z.Range("A1").PasteSpecial (xlPasteValues): z.Range("A1").PasteSpecial (xlPasteFormats)
z.Activate: z.Cells(1, 1).Select
Application.CutCopyMode = False
MsgBox "Done"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Related
So I have produced this code so far, but I cannot get the paste to work.
The idea is run through 190 workbooks and to paste formulas in some cells with constants in others (range H1:Z160) which grade an excel exam. All the formulas and constants paste and work if done manually.
The paste function (labelled) fails with this error:
This is the now updated and corrected code:
Option Explicit
Sub Examnew()
Dim rCell As Range, rRng As Range 'define loop names
Dim wbmaster As Workbook 'name for master workbook
Dim wbtarget As Workbook 'name for student workbook
Set wbmaster = ActiveWorkbook 'set the name for the master
Dim i As Long 'a counter for the result pasteback
With Application '<--|turn off screen & alerts only removed while testing
.ScreenUpdating = False
.EnableEvents = False
End With
i = 1 'Set the counter for result paste back
'Student numbers in cells B3:B136 WARNING SET TO 2 STUDENTS ONLY FOR TEST
'NOTE that st Nums are in col B with a duplicate in col A to collect results.
Set rRng = wbmaster.Sheets("studentlist").Range("B3:B4")
ActiveSheet.DisplayPageBreaks = False '< | turn off page breaks for speed
For Each rCell In rRng '< | loop through "students" range
ActiveSheet.DisplayPageBreaks = False '< | turn off page breaks for speed
'now open Student exam workbook and set to name "wbtarget"
Workbooks.Open ("/Users/michael/Final_V1/" & rCell.Value & ".xlsx")
Set wbtarget = Workbooks(rCell.Value & ".xlsx")
'do copy & paste from Master to Target
wbmaster.Sheets("Answers_Source").Range("h1:z160").Copy
wbtarget.Sheets("ANSWERS").Range("h1:z160").PasteSpecial
Application.CutCopyMode = False 'Clear the copy command
'Now collect the result in cell I4 and paste it back into column B using the rCell
'for that student number matches the st num in col A
wbtarget.Sheets("Answers").Range("I4").Copy
wbmaster.Sheets("studentlist").Range("B" & 2 + i).PasteSpecial xlPasteValues
Application.CutCopyMode = False 'Clear the copy command
'now save and close the student file...
wbtarget.Close (True)
i = i + 1 'increment i for next pasteback
Next rCell '< | next student number
'save the results file
wbmaster.Save
ActiveSheet.DisplayPageBreaks = True '< | turn back on page breaks once all done
'turn screen & alerts back on
With Application
.ScreenUpdating = True: .DisplayAlerts = True
'.DisplayPageBreaks = True
End With
End Sub
Which works perfectly, Thanks guys.
The reason it fails on that line of code is that there is no Paste method for the Range object.
There are 2 ways to copy paste.
1) Send a value to the Destination parameter in the Copy method. You then don't need a Paste command:
wb.Sheets("Answers_Source").Range("h1:z160").Copy _
Destination := wb2.Sheets("Answers").Range("h1:z160")
2) Use the PasteSpecial method on the destination range after copying, which by default pastes everything, like a standard paste.
wb2.Sheets("Answers").Range("h1:z160").PasteSpecial
Then to stop the Marquee (or marching ants) around the cell you copied, finish with Application.CutCopyMode = False
Even though this has been answered, the Range Value property is something that should be included as an option for this question.
If you're only looking to CopyPasteValues, it is probably better to adjust the Range Value Property to be equal to the Source Range Values.
A couple advantages:
No marching ants (Application.CutCopyMode = False).
The screen should not need to flash update/scroll.
Should be faster.
You don't even need to unhide or activate (which you don't with Copying, but people think you do... so I'm listing it!).
So I rebuilt your Macro with the changes, though I didn't make any other changes, so whatever else you fixed, would probably need to be done again. I also included a second macro (TimerMacro) that you can use to time how long it runs (in case you want to test the performance differences). If you're not using any dates, you can use the property Value2 for a very slight speed improvement, although I haven't seen much improvement with this.
Good Luck!
Sub Examnew_NEW()
Dim rCell As Range, rRng As Range 'define loop names
Dim wbmaster As Workbook 'name for master workbook
Dim wbtarget As Workbook 'name for student workbook
Set wbmaster = ActiveWorkbook 'set the name for the master
Dim i As Long 'a counter for the result pasteback
With Application '<--|turn off screen & alerts only removed while testing
.ScreenUpdating = False
.EnableEvents = False
End With
i = 1 'Set the counter for result paste back
'Student numbers in cells B3:B136 WARNING SET TO 2 STUDENTS ONLY FOR TEST
'NOTE that st Nums are in col B with a duplicate in col A to collect results.
Set rRng = wbmaster.Sheets("studentlist").Range("B3:B4")
ActiveSheet.DisplayPageBreaks = False '< | turn off page breaks for speed
For Each rCell In rRng '< | loop through "students" range
ActiveSheet.DisplayPageBreaks = False '< | turn off page breaks for speed
'now open Student exam workbook and set to name "wbtarget"
Workbooks.Open ("/Users/michael/Final_V1/" & rCell.Value & ".xlsx")
Set wbtarget = Workbooks(rCell.Value & ".xlsx")
'do copy & paste from Master to Target
'PGCodeRider CHANGED!!!!!!!!!!!!!!
wbtarget.Sheets("ANSWERS").Range("h1:z160").Value = _
wbmaster.Sheets("Answers_Source").Range("h1:z160").Value
Application.CutCopyMode = False 'Clear the copy command
'Now collect the result in cell I4 and paste it back into column B using the rCell
'for that student number matches the st num in col A
'PGCodeRider CHANGED!!!!!!!!!!!!!!
wbmaster.Sheets("studentlist").Range("B" & 2 + i).Value = _
wbtarget.Sheets("Answers").Range("I4").Value
Application.CutCopyMode = False 'Clear the copy command
'now save and close the student file...
wbtarget.Close (True)
i = i + 1 'increment i for next pasteback
Next rCell '< | next student number
'save the results file
wbmaster.Save
ActiveSheet.DisplayPageBreaks = True '< | turn back on page breaks once all done
'turn screen & alerts back on
With Application
.ScreenUpdating = True: .DisplayAlerts = True
'.DisplayPageBreaks = True
End With
End Sub
Sub timerMACRO()
'Run this if you want to run your macro and then get a timed result
Dim beginTime As Date: beginTime = Now
Call Examnew_NEW
MsgBox DateDiff("S", beginTime, Now) & " seconds."
End Sub
Try removing these With which anyway make no sense in the context.
'do copy from reference "Answers_Source" worksheet
wb.Sheets("Answers_Source").Range("h1:z160").Copy
'now paste the formulas into the student exam workbook
wb2.Sheets("Answers").Range("h1:z160").Paste
Try going to visual basic editor -> tools -> reference. Check the reference that you are using and see if you active all the reference you need. The root cause of this appears to be related to problems mentioned in https://support.microsoft.com/en-ph/help/3025036/cannot-insert-object-error-in-an-activex-custom-office-solution-after and https://blogs.technet.microsoft.com/the_microsoft_excel_support_team_blog/2014/12/
I'm having issues with a workbook not changing view to a newly unhidden/activated worksheet in-between toggling screen updating from off to on and back off again - it's not actually refreshing the screen. (code below)
I have module that calls forms and subs from a main sub to carry out a number of tasks - within each of the subs (except the main) I turn off screen updating in the beginning and turn it on at the end (example below). The workbook has a number of worksheets (mostly hidden) that are used for processing or as the final visible view - when opened, only one sheet is visible (used to launch the main sub).
While running, one of the subs unhides and activates the final worksheet, then deletes the starting worksheet - and toggles screen updating back on ("True"), and exits back to the main sub (which calls another sub again).
But it doesn't change view, the view stays on the deleted sheet while the subs all finish. (I can "trick" it into changing view to the newly active worksheet by inserting a "MsgBox" - but don't want to do that.)
This has been a hard one for me to search out answers (because looking up "Screenupdating" and anything else brings up a myriad of answers regarding "how to stop the screen from updating").
Sub createADS()
Dim oneForm As Object
Set MainWrkBk = ActiveWorkbook
cancel = False 'initialise
Call ADSheaderFormShow
Set MainWrkBk = ActiveWorkbook 're-Set MainWrkBk after doing "SaveAs" in previous form
Call ADSformGen
MainWrkBk.Worksheets("ADSform").Activate 'Doesn't change view
'MsgBox "Enter antenna information from RFDS"
'^^^ Tricks it into refreshing worksheet when active
Call ADSinputFormShow
Call ADSsetAntennas
Call ADSpullData
GoTo ExitHandler
ExitHandler:
For Each oneForm In UserForms
Unload oneForm
ThisWorkbook.Save
Next oneForm
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub ADSformGen()
Application.ScreenUpdating = False 'Returned to True after running sub
MainWrkBk.Worksheets("HidDbSh").Visible = True
MainWrkBk.Worksheets("HidDbSh").Cells(1, 1).Value = "Site Info"
MainWrkBk.Worksheets("HidSiteTemp").Range("a1").CurrentRegion.Copy _
Destination:=MainWrkBk.Worksheets("HidDbSh").Cells(2, 1)
Columns.AutoFit
Application.Calculation = xlCalculationAutomatic 'to reset all formula calcs before deleting source
MainWrkBk.Worksheets("HidDbSh").Visible = False
Application.DisplayAlerts = False
MainWrkBk.Worksheets("HidSiteTemp").Delete
Application.DisplayAlerts = True
MainWrkBk.Worksheets("HidADSform").Visible = True
MainWrkBk.Worksheets("HidADSform").Name = "ADSform"
With MainWrkBk.Worksheets("ADSform").UsedRange
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
Application.DisplayAlerts = False
MainWrkBk.Worksheets("BlankADSForm").Delete
Application.DisplayAlerts = True
MainWrkBk.Worksheets("ADSform").Activate
MainWrkBk.Worksheets("ADSform").Range("B2").Select
Application.ScreenUpdating = True
End Sub
If you want to ensure that the screen updates when you active the sheet, turn screen updating on before you active it. Otherwise, you risk the redraw event that the Activate call will generate getting swallowed:
'...
Application.ScreenUpdating = True
MainWrkBk.Worksheets("ADSform").Activate
MainWrkBk.Worksheets("ADSform").Range("B2").Select
End Sub
This question already has answers here:
Improving the performance of FOR loop
(3 answers)
Closed 7 years ago.
Trying to use Union and ranges to speed up deleting empty columns, across all sheets in my workbook, except "AA" and "Word Frequency"
Sample workbook
Example of sheet before:
Example of sheet after (note, I will need to write separate script to shift keywords up, you can't see all the keywords, but only the columns with data in them are left):
In my search for a method to speed up deleting columns in a sheet if the column is empty (except the header), I was directed by #chrisneilsen to reference the thread Improving the performance of FOR loop.
That thread shed light on the fact that deleting columns individually slows down performance significantly. Script speed can be improved by defining a "master" range to include all the ranges (columns) to be deleted (by using Union), and then simply deleting the "master" range.
As a VBA noob, I used to following references to learn about Ranges, Union, UBound and LBound to understand the code in the thread mentioned above:
Excel-Easy.com: Using UBound and LBound, Dynamic Arrays (Using ReDim)
Youtube: Using UNION method to select (and modify) multiple ranges
My old (slow) script that works, but takes about about 3 hours to run across ~30 sheets and deleting ~100 columns each sheet:
Sub Delete_No_Data_Columns()
Dim col As Long
Dim h 'to store the last columns/header
h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
Application.ScreenUpdating = False
For col = h To 5 Step -1
If Application.CountA(Columns(col)) = 1 Then Columns(col).Delete
Next col
End Sub
Almost working script (for one sheet), using the same approach as #chrisneilsen code in thread mentioned above. When I run it, it doesn't do anything, however #chrisneilsen noted there were 2 syntax errors (Column. instead of Columns.) and that I was mixing an implicit ActiveSheet (by using Columns without a qualifier) with an explicit sheet Worksheets("Ball Shaker"). Errors in code are commented below.
Sub Delete_No_Data_Columns_Optimized()
Dim col As Long
Dim h 'to store the last columns/header
Dim EventState As Boolean, CalcState As XlCalculation, PageBreakState As Boolean
Dim columnsToDelete As Range
Dim ws as Worksheet '<<<<<<<<< Fixing Error (qualifying "Columns." properly)
On Error GoTo EH:
'Optimize Performance
Application.ScreenUpdating = False
EventState = Application.EnableEvents
Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
' <<<<<<<<<<<<< MAIN CODE >>>>>>>>>>>>>>
Set ws = ActiveSheet
h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
'<<<<<<<<<<<<<< Errors corrected below in comments >>>>>>>>>>>>
For col = h To 5 Step -1
If Application.CountA(Column(col)) = 1 Then
'<<<<< should be Application.CountA(ws.Columns(col)) = 1
If columnsToDelete Is Nothing Then
Set columnsToDelete = Worksheets("Ball Shaker").Column(col)
'should be columnsToDelete = ws.Columns(col)
Else
Set columnsToDelete = Application.Union(columnsToDelete, Worksheets("Ball Shaker").Column(col))
'should be columnsToDelete = Application.Union(columnsToDelete, ws.Columns(col))
End If
End If
Next col
'<<<<<<<<<<<<<< End Errors >>>>>>>>>>>>>>>>
If Not columnsToDelete Is Nothing Then
columnsToDelete.Delete
End If
' <<<<<<<<<<<< END MAIN CODE >>>>>>>>>>>>>>
CleanUp:
'Revert optmizing lines
On Error Resume Next
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True
Exit Sub
EH:
' Handle Errors here
Resume CleanUp
End Sub
Working code that runs across all sheets in workbook, in about ~6 minutes (except "AA" and "Word Frequency" worksheets, which I don't need to format):
Option Explicit
Sub Delete_No_Data_Columns_Optimized_AllSheets()
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name <> "AA" And sht.Name <> "Word Frequency" Then
sht.Activate 'go to that Sheet!
Delete_No_Data_Columns_Optimized sht.Index 'run the code, and pass the sht.Index _
'of the current sheet to select that sheet
End If
Next sht 'next sheet please!
End Sub
Sub Delete_No_Data_Columns_Optimized(shtIndex As Integer)
Dim col As Long
Dim h 'to store the last columns/header
Dim EventState As Boolean, CalcState As XlCalculation, PageBreakState As Boolean
Dim columnsToDelete As Range
Dim ws As Worksheet
Set ws = Sheets(shtIndex) 'Set the exact sheet, not just the one that is active _
'and then you will go through all the sheets
On Error GoTo EH:
'Optimize Performance
Application.ScreenUpdating = False
EventState = Application.EnableEvents
Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
' <<<<<<<<<<<<< MAIN CODE >>>>>>>>>>>>>>
h = ws.Range("E1").End(xlToRight).Column 'find the last column with the data/header
For col = h To 5 Step -1
If ws.Application.CountA(Columns(col)) = 1 Then 'Columns(col).Delete
If columnsToDelete Is Nothing Then
Set columnsToDelete = ws.Columns(col)
Else
Set columnsToDelete = Application.Union(columnsToDelete, ws.Columns(col))
End If
End If
Next col
If Not columnsToDelete Is Nothing Then
columnsToDelete.Delete
End If
' <<<<<<<<<<<< END MAIN CODE >>>>>>>>>>>>>>
CleanUp:
'Revert optmizing lines
On Error Resume Next
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True
Exit Sub
EH:
' Handle Errors here
Resume CleanUp
End Sub
Note: Trying to delete columns and shift to left, so columns with data inside will all be grouped together neatly after script is run.
Is this the best way to utilize Union and ranges for deleting columns? Any help would be greatly appreciated.
The special cells method actually will not serve you so well here. Instead, find the last row of data in your sheet and delete only the cells in the column up to the that row and shift everything to the left. This will be much faster than deleting an entire column!
Sub Delete_No_Data_Columns()
Dim col As Long, lRow as Long
Dim h as Long'to store the last columns/header
lRow = Range("E" & Rows.Count).End(xlUp).Row ' assumes column E will have last used row ... adjust as needed
h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
For col = h To 5 Step -1
If Application.CountA(Columns(col)) = 1 Then
Range(Cells(2,col),Cells(lRow,col)).Delete shift:=xlToLeft
End If
Next col
Application.ScreenUpdating = False ' i think you want this at the beginning of the program, no?
End Sub
At work, we've developed a tool using Excel and VBA. This tool has hidden sheets that will only be opened once the previous step is complete. One of the issues I'm running into from the previous coder is that the very last step, there is an extra button, let's call it A, that can be clicked. Based on the order of sheets the previous coder created, this sheet was second out of 10, and when A is clicked, its automatically goes to the second position.
Is there any way I can modify it to the the right most tab?
The problem I run into is when I get to the final step, I can manually move the tab to the right hand side, but that is only after I have finished my analysis, and can not go to the beginning, so it does not allow me to save.
This will move your hidden sheet to end of all visible sheets:
Sub test()
With Sheets("Sheet1")
.Visible = True
Sheets("Sheet1").Move After:=Sheets(Sheets.Count)
.Visible = False
End With
End Sub
And this will move your hidden sheet to the end of all hidden and visible sheets:
Sub moveHiddenSheet()
Dim ws, x, lastSheet
x = 0
For ws = Worksheets.Count To 0 Step -1
x = x + 1
If Sheets(Worksheets.Count - x).Visible = False Then
Sheets(ws).Visible = xlSheetVisible
lastSheet = Sheets(ws).Name
Exit For
End If
Next ws
With Sheets("Sheet1")
.Visible = True
Sheets("Sheet1").Move After:=Sheets(Worksheets.Count)
.Visible = False
End With
Sheets(lastSheet).Visible = False
End Sub
I am writing a short macro to hide all customers that have no current sales for the current year. The YTD sales are in the K column (specifically K10-250). Those cells use a vlookup to pull data from another tab where we dump data. My question is why on earth would this macro take 10-15minutes to run? I have a similar macro on another spreadsheet that takes only 2-3 minutes for over 1,500 rows. I have already turned off screen updating. I can't think of anything else that would speed it up.
Sub HideNoSlackers()
'
' HideNoSlackers Macro
'
'
Application.ScreenUpdating = False
'
Sheets("CONSOLIDATED DATA").Select
Dim cell As Range
For Each cell In Range("K10:K250")
If cell.Value = 0 Then
cell.EntireRow.Hidden = True
Else
cell.EntireRow.Hidden = False
End If
Next
End Sub
You might want the calculation to be set Manual before hiding the rows? Also you can get rid of If statements in your case. Try this:
Sub HideNoSlackers()
Dim cell As Range, lCalcState As Long
Application.ScreenUpdating = False
' Record the original Calculation state and set it to Manual
lCalcState = Application.Calculation
Application.Calculation = xlCalculationManual
For Each cell In ThisWorkbook.Worksheets("CONSOLIDATED DATA").Range("K10:K250")
cell.EntireRow.Hidden = (cell.Value = 0)
Next
' Restore the original Calculation state
Application.Calculation = lCalcState
Application.ScreenUpdating = True ' Don't forget set ScreenUpdating back to True!
End Sub
Sub HideNoSlackers()
Dim cell As Range, rng As Range, rngHide As Range
Set rng = Sheets("CONSOLIDATED DATA").Range("K10:K250")
rng.EntireRow.Hidden = False
For Each cell In rng.Cells
If cell.Value = 0 Then
If Not rngHide Is Nothing Then
Set rngHide = Application.Union(rngHide, cell)
Else
Set rngHide = cell
End If
End If
Next
If Not rngHide Is Nothing Then rngHide.EntireRow.Hidden = True
End Sub
Why are you doing this with a macro?
If you create a table over the data, you can set up a filter on the sales column that will show only those where sales<> 0.
Macros are useful in excel but the majority of actions that people turn to macros for can be done natively in excel.
there must be something else that's wrong. Try without .Selecting the sheet but that's not a huge improvement
Note rows are visible by default so the Else statement should be optional really.
Sub HideNoSlackers()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Sheets("CONSOLIDATED DATA").Cells.EntireRow.Hidden = False
Dim cell As Range
For Each cell In Sheets("CONSOLIDATED DATA").Range("K10:K250")
If cell.Value = 0 Then cell.EntireRow.Hidden = True
Next
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
the shortest code to achieve the same Goal in a very different way:
Sub column_K_not_NULL
Sheets("CONSOLIDATED DATA").Select
If ActiveSheet.FilterMode Then Selection.AutoFilter 'if an autofilter already exists this is removed
ActiveSheet.Range("$K$10:$K$250").AutoFilter Field:=1, Criteria1:="<>0"
End Sub
of course you could put in the standard minimums like
application.calculation = Manual
Application.ScreenUpdating = False
and other way round at the end.
Max
Try disabling page breaks. I had a similar problem that would happen after someone printed from the sheet. This turned on page breaks, and subsequent runs of the script would take forever.
ActiveSheet.DisplayPageBreaks = False
We found out, that the program Syncplicity in the Version 4.1.0.1533 slows down macros up to 15times slower because events trigger syncplicity.
with
Application.EnableEvents = False
;do your job here
Application.EnableEvents = True
the speed is back.