In a large project I add a large number of shapes at different positions in a Worksheet. Furthermore, I insert a number of rows.
I want the shapes to move with the inserted rows. However, they only do so with Application.ScreenUpdating = True. As soon as ScreenUpdating is set False, the shapes stop moving. This of course messes up the results completely.
I cannot reproduce the problem. In this minimal example, the inserted shapes move as expected with the inserted row, although I use Application.ScreenUpdating = False. In my larger program the basically identical procedure fails without ScreenUdating.
Sub ShapeTest()
Dim ActiveShape As Shape
Dim ShapeCell As Range
Application.ScreenUpdating = False
Set ShapeCell = ActiveSheet.Range("A1")
Set ActiveShape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ShapeCell.Left, ShapeCell.Top, ShapeCell.Width, ShapeCell.Height)
ActiveSheet.Rows(1).Insert shift:=xlShiftDown
Application.ScreenUpdating = True
End Sub
Update
I have tried DoEvents before and after inserting the row, but it didn't change anything. Currently I am using this workaround:
Application.ScreenUpdating = True
Worksheets("Gantt").Rows(ThisRowGTT).Insert shift:=xlShiftDown
Application.ScreenUpdating = False
This slows down the execution alot - almost as if I would use ScreenUpdating for the entire program.
Related
I'm going through a peculiar failure in my excel vba macro wherein the excel sheet crashes on the 2nd run of the macro (Yes, 1st run in perfect).
This macro is to delete all data labels except the recent one for a particular series in all graphs in a sheet. Common graph is used with slicer and Data table to select which line item is needed in graph. on every change in slicer (new line items is selected in data table filter), i want the macro to run and do the label work.
Below is source code for the Graph data label work,
Sub Update_labels_Only_To_Last_Data()
Dim myChartObject As ChartObject
Dim mySrs As Series
Dim myPts As Points
Dim iPts As Long
Dim bLabeled As Boolean
Application.EnableEvents = False
Name = ThisWorkbook.Name
Set Wb = Workbooks(Name)
Set WsGraph = Wb.Worksheets("Graph")
WsGraph.Activate
With ActiveSheet
For Each myChartObject In .ChartObjects
For Each mySrs In myChartObject.Chart.SeriesCollection
If mySrs.Name = "TAR" Then
bLabeled = False
With mySrs
For iPts = .Points.Count To 1 Step -1
If bLabeled Then
' handle error if point isn't plotted
On Error Resume Next
' remove existing label if it's not the last point
mySrs.Points(iPts).HasDataLabel = False
On Error GoTo 0
Else
' handle error if point isn't plotted
On Error Resume Next
' add label
mySrs.Points(iPts).ApplyDataLabels _
ShowSeriesName:=False, _
ShowCategoryName:=False, ShowValue:=True, _
AutoText:=True, LegendKey:=False
bLabeled = (Err.Number = 0)
On Error GoTo 0
End If
Next
End With
Set myPts = mySrs.Points
myPts(myPts.Count).ApplyDataLabels Type:=xlShowValue 'Add only to last data
End If
Next
Next
End With
'End If
Application.EnableEvents = True
End Sub
I've tried running macro using a separate button it works perfectly. Then linked this with event macro (Calculation) using below code in sheet (Donotdelete)
Option Explicit
Private Sub Worksheet_Calculate()
Dim Act_Sheet As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculate
If Not Application.CalculationState = xlDone Then 'wait till previous calculation gets over
DoEvents
End If
Set Act_Sheet = ActiveSheet
Application.Wait (Now + TimeValue("0:00:01"))
Call Update_labels_Only_To_Last_Data
Act_Sheet.Activate
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
so once a slicer filter is changed, calculate event is triggered using "Count" function in "Donotdelete" sheet and macro gets run. when first time slicer us changed, macro works perfectly. but when 2nd time the slicer is changed to call different graph, macro gets initiated and all of a sudden, completely sheet gets crashed/closed. Tried in break mode and the code works perfectly. tried giving doevents / wait options and still the result is same. To confirm the crash source, tried skipping the "macro" using comment block in eventmacro sheet & the code works perfectly. on any selection change in slicer, macro goes thro the event macro and works perfectly. with this, source is confirmed to be the macro "Update_labels_Only_To_Last_Data()".
i use the same macro in main module and there it works perfectly any number of consecutive times. could not find why it crashes only when used through even trigger and only on the 2nd time !!!. did all my google help thing for couple of weeks now but no result. see if you guys can show me a wayout.
I have a script that automates setting some filters on a pivot table depending on the data (hiding and showing certain articles). Now the script works great but when I have a pivot chart it gets super slow. I think what's happening in the background is that the chart is re-calculated for every article I show/hide.
Is there a way to set multiple filters without updating the table and then update the pivot chart & table once they are all set?
I thought about deleting the chart, setting the filters and then re-creating the chart. But this would remove any formatting I set on the chart so I would prefer not to go that path.
Sub btnVar() ' function to show only articles with variable data
onlyVar (True)
End Sub
Sub btnConst() ' function to show only articles with constant data
onlyVar (False)
End Sub
Sub onlyVar(check As Boolean)
calcOff 'disable screen updates etc
'first show all articles
ActiveSheet.PivotTables("PivotTable1").PivotFields("Artikel").ClearAllFilters
Dim dict As Dictionary
Set dict = New Dictionary
art = 9 'start from column 9
article = Sheet4.Cells(3, art).Value 'first article name
lrow = Cells(Rows.Count, art).End(xlUp).Row 'find last row
' set article visibility in dictionary according to desired filter (constant/variable
Do While article <> "" 'loop over article names until end of table
If Sheet4.Cells(4, art).Value = Application.Average(Range(Cells(4, art), Cells(lrow, art))) Then
dict.Add article, Not check
Else
dict.Add article, check
End If
art = art + 1
article = Sheet4.Cells(3, art).Value
Loop
' set the filters, this causes the table & chart to update every time a filter is set.
' it is fine for table only but with chart it gets super slow.
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Artikel")
For Each ptitm In .PivotItems
ptitm.Visible = dict.Item(ptitm.Name)
Next
End With
calcOn 're-enable screen updates etc
End Sub
Public Sub calcOff()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
End Sub
Public Sub calcOn()
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Any help to make this faster would be appreciated. Thanks in advance!
I have a large VBA/Excel project .xlsm file that has all of a sudden begun to stop responding (am forced to force quit Excel) when I click the Remove Row button that calls my RemoveComparison sub. The strange thing is that the sub occasionally works (and has worked in the past). It is as if Excel sometimes maxes out on memory when this RemoveComparison gets called and other times it does not. The problem goes away if I comment out Application.Calculation = xlAutomatic in the last line. When RemoveComparison does work, however, it takes about 2 full seconds to complete since I believe the hiding of rows or maybe the deleting of the OLEObjects triggers a large recalculation on other sheets when I set calculation mode back to xlAutomatic.
Does anyone spot what could be causing Excel to stop responding?
Here is a screenshot of the Workbook. The Remove Row button calls the sub RemoveComparison() that deletes ComboBoxManagerComparison7 in this case (the one with S&P 500) and also deletes Comparison7CheckBox before hiding the cells (which contain formulas referencing other sheets). If the Remove Row works like it did before, clicking the button a second time would remove Comparison6, etc.
Sub RemoveComparison()
Application.Calculation = xlManual
Dim CurrentNumberOfComparisons As Integer
With Sheets("Manager")
'get current number of comparisons (to determine which ComboBox, etc. to remove)
CurrentNumberOfComparisons = .Range("NumberOfComparisons").Value
If CurrentNumberOfComparisons = 1 Then
MsgBox ("Min 1 comparison")
Exit Sub
End If
Dim ComboBoxName As String
'determine name of ComboBox to remove
ComboBoxName = "ComboBoxManagerComparison" & CurrentNumberOfComparisons
Call DeleteComboBox(ComboBoxName, Sheets("Manager"))
#If DEBUGREMOVECOMPARISON Then
Debug.Print "Deleted ComboBox"
#End If
Dim CheckBoxName As String
'determine name of CheckBox to remove
CheckBoxName = "Comparison" & CurrentNumberOfComparisons & "CheckBox"
Call DeleteCheckBox(CheckBoxName, Sheets("Manager"))
#If DEBUGREMOVECOMPARISON Then
Debug.Print "Deleted CheckBox"
#End If
Dim ComparisonCellToHideNamedRange As String
'determine which cells to hide
ComparisonCellToHideNamedRange = "selectedManagerComparison" & CurrentNumberOfComparisons & "Name"
Dim ComparisonCellToHide As Range
Set ComparisonCellToHide = .Range(ComparisonCellToHideNamedRange)
Range(Rows(ComparisonCellToHide.row), Rows(ComparisonCellToHide.row + 3)).Hidden = True
'update current number of comparisons
.Range("NumberOfComparisons").Value = CurrentNumberOfComparisons - 1
#If DEBUGREMOVECOMPARISON Then
Debug.Print "Success"
#End If
End With
Application.Calculation = xlAutomatic
End Sub
Sub DeleteComboBox(ComboBoxName As String, Sheet As Worksheet)
With Sheet
.OLEObjects(ComboBoxName).Delete
End With
End Sub
Sub DeleteCheckBox(CheckBoxName As String, Sheet As Worksheet)
With Sheet
.OLEObjects(CheckBoxName).Delete
End With
End Sub
EDIT: Still unclear why the switch from xlManual back to xlAutomatic in the sub leads to Not Responding, but if I comment out the last line of the sub Application.Calculation = xlAutomatic and manually click Formulas->Calculation Options->Automatic, the entire worksheet is recalculated even if no cells are edited. I understand that hiding cells causes a recalculation, but should hiding a row cause the recalculation of the whole worksheet (even when the hidden row has no dependents)?
EDIT: Excel stops crashing if I move the ComboBoxes and CheckBoxes to another part of the sheet rather than deleting them in the sub. I am not sure why the deletion of these OLEObjects caused Excel enter not responding.
I am using a worksheet change function to give my excel spread sheet the illusion of a search bar with a drop down box containing the results of the text in the search bar.
before I just had the hide rows part of my code which would hide and then unhide some rows in my spread sheet containing the results. that worked fine but the results would sometimes be slow and not always show up until I re calculated them.
so I added calculate to the ranges and this unfortunately slows the whole thing down substantially. Is there a better way to do this?
Private Sub Worksheet_Change(ByVal target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
If Range("D11").Value <> "" Then
Dim xlpassword As String
xlpassword = "Perry2012"
ActiveSheet.Unprotect xlpassword
ActiveSheet.EnableCalculation = False
ActiveSheet.EnableCalculation = True
Worksheets("HOME").Range("A1").Calculate
Worksheets("HOME").Range("D33").Calculate
Worksheets("HOME").Range("D32").Calculate
Worksheets("HOME").Range("E33").Calculate
Worksheets("HOME").Range("E32").Calculate
Worksheets("HOME").Range("F33").Calculate
Worksheets("HOME").Range("F32").Calculate
Worksheets("HOME").Range("G33").Calculate
Worksheets("HOME").Range("G32").Calculate
Worksheets("HOME").Range("H33").Calculate
Worksheets("HOME").Range("H32").Calculate
Worksheets("HOME").Range("I33").Calculate
Worksheets("HOME").Range("I32").Calculate
Worksheets("HOME").Range("J33").Calculate
Worksheets("HOME").Range("J32").Calculate
Worksheets("HOME").Range("K33").Calculate
Worksheets("HOME").Range("K32").Calculate
Worksheets("HOME").Range("L33").Calculate
Worksheets("HOME").Range("L32").Calculate
Worksheets("HOME").Range("M33").Calculate
Worksheets("HOME").Range("M32").Calculate
Worksheets("HOME").Range("N33").Calculate
Worksheets("HOME").Range("N32").Calculate
Worksheets("HOME").Range("O33").Calculate
Worksheets("HOME").Range("O32").Calculate
Worksheets("HOME").Range("P33").Calculate
Worksheets("HOME").Range("P32").Calculate
Worksheets("HOME").Range("Q33").Calculate
Worksheets("HOME").Range("Q32").Calculate
Worksheets("HOME").Range("R33").Calculate
Worksheets("HOME").Range("R32").Calculate
Worksheets("HOME").Range("S33").Calculate
Worksheets("HOME").Range("S32").Calculate
Worksheets("HOME").Range("T33").Calculate
Worksheets("HOME").Range("T32").Calculate
Worksheets("HOME").Range("U33").Calculate
Worksheets("HOME").Range("U32").Calculate
Worksheets("HOME").Range("V33").Calculate
Worksheets("HOME").Range("V32").Calculate
Worksheets("HOME").Range("W33").Calculate
Worksheets("HOME").Range("W32").Calculate
Worksheets("HOME").Range("D15").Calculate
Worksheets("HOME").Range("D17").Calculate
Worksheets("HOME").Range("D19").Calculate
Worksheets("HOME").Range("D21").Calculate
Worksheets("HOME").Range("D23").Calculate
Worksheets("HOME").Range("D25").Calculate
Worksheets("HOME").Range("D27").Calculate
Worksheets("HOME").Range("M15").Calculate
Worksheets("HOME").Range("M17").Calculate
Worksheets("HOME").Range("M19").Calculate
Worksheets("HOME").Range("M21").Calculate
Worksheets("HOME").Range("M23").Calculate
Worksheets("HOME").Range("M25").Calculate
Worksheets("HOME").Range("M27").Calculate
Worksheets("HOME").Range("T15").Calculate
Worksheets("HOME").Range("T17").Calculate
Worksheets("HOME").Range("T19").Calculate
Worksheets("HOME").Range("T21").Calculate
Worksheets("HOME").Range("T23").Calculate
Worksheets("HOME").Range("T25").Calculate
Worksheets("HOME").Range("T27").Calculate
Rows("15:28").Hidden = False
Rows("34:36").Hidden = True
Else
Rows("15:28").Hidden = True
Rows("34:36").Hidden = False
ActiveSheet.Protect xlpassword
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Would replacing all those separate lines by just one work:
Application.Calculate
it might be the case that you have some volatile functions heavily used in the workbook(i.e. TODAY()), which I reckon will make all formulas based on them re-calculate on each of those calculation lines in your code
I have a sheet that displays data in shapes to look nice. These shapes simply reference a cell in a data staging sheet. The data in the staging area is using a getpivotdata formula to lookup data.
On my display sheet with the shapes that display values to the user, there is also a combo box that changes the pivot table. When the pivot table is changed it updates the data in the staging area which in turn changes the data in the shapes on the display sheet. I then call a macro that sets the shapes to green if >0 or red if <0.
The problem is that while the pivot data is changing and being recalculated my shapes keep having their colours changed in accordance to the old values as the new fields haven't been calculated yet.
I've tried DoEvents but have little experience as to what it does and had no luck. I don't want to delay by a fixed time because that's just horrible. I've also tried calling StagingSheet.calculate before calling my updateColours macro without success.
Any ideas?
You could try Application.ScreenUpdating = false. E.g.:
Sub AllWorkbookPivots()
Dim pt As PivotTable
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each ws In ActiveWorkbook.Worksheets
For Each pt In ws.PivotTables
pt.RefreshTable
Next pt
Next ws
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
That might work.
So to make sure the values are calculated before the colour change is called I used the following macro to make the application wait until the calculations were done.
Sub WaitForCalculate()
Application.Cursor = xlWait
Application.EnableEvents = False
Do Until Application.CalculationState = xlDone
DoEvents
Loop
Application.EnableEvents = True
Application.Cursor = xlDefault
End Sub
Not very pretty but gets the job done.