Worksheet_Change setting target range is slow - vba

I have an excel macro used to manage button visibility in Excel in the "Worksheet_Change" function based from another SO question here.
The problem is the although the macro works it makes updating the Excel sheet rather laggy. I have managed to pin down the slowness to a single line:
Set rUpdated = Range(Target.Dependents.Address)
This sets the range of cells updated to a variable to be iterated through later in the script. If I call a script with just this line I found this is where all the delay is. It seems a rather simple line, but is there a better way to do it?
Full disclosure:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rUpdated As Range
Dim shp As Shape
Dim rCell As Range
Set rUpdated = Range(Target.Dependents.Address)
If Not rUpdated Is Nothing Then
For Each rCell In rUpdated
If rCell.Column = 1 Then
'Look at each shape in the sheet and cross-reference with rCell.
For Each shp In Target.Parent.Shapes
If shp.TopLeftCell.Row = rCell.Row Then
shp.Visible = (rCell.Value <> "")
Exit For 'Exit the loop - the correct button has been found.
End If
Next shp
End If
Next rCell
End If
End Sub

So if i understood it correctly you want to make a button visible if the cell in the row as been changed. The only things i can think of to slow it down are, that is has to check many rCell or Shapes. I dont know what the structure of your document is. So my Idea would be: instead of going through all shapes every time, i would name them in a pattern that you can identify them with the row they are in so you use the name to address them (i.e Row2 for the Button in Row 2).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rUpdated As Range
Dim shp As Shape
Dim rCell As Range
Dim obj As OLEObject
Set rUpdated = Range(Target.Dependents.Address)
If Not rUpdated Is Nothing Then
For Each rCell In rUpdated
If rCell.Column = 1 Then
On Error Resume Next
Set obj = ActiveSheet.OLEObjects("Row" & rCell.Row)
If Err.Number = 0 Then
obj.Visible = (rCell.Value <> "")
End If
End If
Next rCell
End If
End Sub

I replaced that config with the following single line (and companion line):
On Error Resume Next
ActiveSheet.Shapes("buttonRow" & Target.Row).Visible = (ActiveSheet.Cells(Target.Row, 1).Value <> "")
However to get this to work I first needed to rename all my shapes. I used this function to do that:
Function renamebuttons()
For Each shp In ActiveSheet.Shapes
shp.name = "buttonRow" & shp.TopLeftCell.Row
Next shp
End Function
I ran that function once and deleted it. Once done my shapes can now be referred to by name and I no longer incur the delay of cycling through every shape and every target dependent. The delay experienced in the worksheet is now minimal.

Related

Excel VBA - Change button visibility based on update to adjacent cell

I have data in column "AK" and a button in Column "AL"; there are several hundred rows and there is only one macro for all buttons as it uses relative references based on the row it is in.
I want the button to only be visible when there is data in the adjacent cell. The following pseudo-code explains what I am trying to achieve:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 37 Then
If Target.Value = 0 Then
Shapes(Target.offset(0, 1)).Visible = False
Else
Shapes(Target.offset(0, 1)).Visible = True
End If
End If
End Sub
The reason for doing this is that the value in AK is calculated based on other values and only displays once all mandatory fields have been completed. The button should only be available for an automation task once all details are complete. What real code would make this work without having to call each button out individually?
I'm not sure if you can directly reference a shape by its location on the sheet.
This code will look at each shape until it finds the one to the right of the cell you've just changed, it will then change the visibility based on the contents of the cell.
(Target.Value <> "") returns TRUE/FALSE.
This will only work if your buttons are placed in the correct cell (slightly too high and it will return the cell above).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
For Each shp In ThisWorkbook.Worksheets("Sheet1").Shapes
If shp.TopLeftCell.Address = Target.Offset(, 1).Address Then
shp.Visible = (Target.Value <> "")
Exit For 'Exit the loop - the correct button has been found.
End If
Next shp
End Sub
Edit:
I've updated the code so it checks that only a single cell has been changed and then looks at each dependent cell of the cell that was changed.
This will probably muck up if the dependent cell is on another sheet though.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rUpdated As Range
Dim shp As Shape
Dim rCell As Range
If Target.Cells.Count = 1 Then
'Hopefully someone will have better code than On Error....
On Error Resume Next
Set rUpdated = Range(Target.Dependents.Address)
On Error GoTo 0
If Not rUpdated Is Nothing Then
'Look at each dependent cell in rUpdated.
For Each rCell In rUpdated
'Look at each shape in the sheet and cross-reference with rCell.
For Each shp In Target.Parent.Shapes
If shp.TopLeftCell.Address = rCell.Offset(, 1).Address Then
shp.Visible = (Target.Value = 0)
Exit For 'Exit the loop - the correct button has been found.
End If
Next shp
Next rCell
End If
End If
End Sub
NB: I got the idea for checking the dependent cell from here: How can I run a VBA code each time a cell get is value changed by a formula?

Populating ComboBox with dynamic values from another worksheet

---Update---
Thanks for the responses, I have found that DragonSamu's updated answer works perfectly.
---Original Post---
I have been trying to figure out where I am going wrong for the past few hours but I can't spot it. I think it's because the script is trying to draw the value from the active worksheet which is not what I want. Hopefully somebody can put me on the rite track - I think the answer should be relatively obvious but I just can't see it!
Basically, I am trying to populate a Combobox with a dynamic range of values that exist in another worksheet (but in the same workbook). I can get the Combobox to populate when I run the script in the worksheet 'Materials' (which is where the dynamic list is drawn from) but not when I run it in the worksheet 'Products'.
Unfortunately the script is designed to populate Products with Materials so is be run in a UserForm when the 'Products' worksheet is open and the 'Materials' worksheet would therefore be inactive.
I should also note that this script has been adapted from code I found elsewhere on this forum, so if it seems familiar I thank you in advance :)
Private Sub UserForm_Initialize()
Dim rRange As Range
On Error GoTo ErrorHandle
'We set our range = the cell B7 in Materials
Set rRange = Worksheets("Materials").Range("B7")
'Check if the cell is empty
If Len(rRange.Formula) = 0 Then
MsgBox "The list is empty"
GoTo BeforeExit
End If
'Finds the next empty row and expands rRange
If Len(rRange.Offset(1, 0).Formula) > 0 Then
Set rRange = Range(rRange, rRange.End(xlDown))
End If
'The range's address is our rowsource
Mat1_Name_ComBox.RowSource = rRange.Address
Mat2_Name_ComBox.RowSource = rRange.Address
Mat3_Name_ComBox.RowSource = rRange.Address
Mat4_Name_ComBox.RowSource = rRange.Address
Mat5_Name_ComBox.RowSource = rRange.Address
BeforeExit:
Set rRange = Nothing
Exit Sub
ErrorHandle:
MsgBox Err.Description
Resume BeforeExit
End Sub
Any help is much appreciated.
Cheers,
Simon
From what I can see your code would be giving an error here:
If Len(rRange.Offset(1, 0).Formula) > 0 Then
Set rRange = Range(rRange, rRange.End(xlDown))
End If
Because your trying to set rRange by using Range() without defining the Worksheet first. This will get the Range from the ActiveWorksheet.
change it to the following:
If Len(rRange.Offset(1, 0).Formula) > 0 Then
Set rRange = Worksheets("Materials").Range(rRange, rRange.End(xlDown))
End If
best practice would be the following:
Private Sub UserForm_Initialize()
Dim wb as Workbook
Dim sh as Worksheet
Dim rRange As Range
On Error GoTo ErrorHandle
'Set the Workbook and Worksheet
set wb = Workbooks("products.xlsx")
set sh = wb.Worksheets("Materials")
'We set our range = the cell B7 in Materials
Set rRange = sh.Range("B7")
'Check if the cell is empty
If Len(rRange.Formula) = 0 Then
MsgBox "The list is empty"
GoTo BeforeExit
End If
'Finds the next empty row and expands rRange
If Len(rRange.Offset(1, 0).Formula) > 0 Then
Set rRange = sh.Range(rRange, rRange.End(xlDown))
End If
By properly defining and setting your Workbook and Worksheet you correctly reference to them and don't get errors.
Update:
the 2nd problem is that rRange.Address only places the Range location inside your .RowSource not the Sheet it needs to look at.
change:
Mat1_Name_ComBox.RowSource = rRange.Address
to:
dim strSheet as String
strSheet = "Materials"
Mat1_Name_ComBox.RowSource = strSheet + "!" + rRange.Address
This way it will include the Sheet name into the .RowSource

Hiding Reference Errors using Font colour in VBA

Hi there i have this code which changes cells with reference errors to white fonts. However i could only do so for a single sheet. range. How do i change the for each loop to loop for all the worksheets in the workbook? I used this code below but it does not seem to work!
Sub Delete_ref_basedontextcondition()
Dim R As Range
'Set rng = Nothing
On Error Resume Next
Set R = Application.InputBox("Select cells To be deleted", Type:=8)
Dim rng As Range
If TypeName(R) <> "Range" Then
Exit Sub
Else
R.Delete
End If
For k = 1 To ThisWorkbook.Worksheets.Count 'runs through all worksheets
Set wks = ThisWorkbook.Worksheets(k)
For Each cell In wks
If cell.Text = "#REF!" Then
cell.Font.Color = RGB(255, 255, 255)
End If
Next
Next
End Sub
While I disagree with your method of hiding #REF! errors rather than dealing with them so that they are not #REF! errors (or deleting the formulas that are creating them, here is some standard 'loop-through-the-worksheets' code that you should be able to adapt for your purposes.
Sub bad_ref()
Dim w As Long, ref As Range
On Error Resume Next
For w = 1 To Worksheets.Count
With Worksheets(w)
For Each ref In .Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
If ref.Text = "#REF!" Then
ref.Font.ColorIndex = 2
'ref.clear '<~~this clears formatting, formulas. etc from the rogue cell.
End If
Next ref
End With
Next w
End Sub
It should run through quickly enough. Rather than examine every cell on each worksheet, I've narrowed down the cells to be critiqued with the Range.SpecialCells method, looking only through the formulas that produce errors. Something like a #N/A error will be left alone.
I've left an option to actually do something with the errors as a commented line.

Remove reference errors autmatically

i have designed a few codes to help remove reference errors however it does not automatically delete until i assign the macro to a button. i do not want it that way as it would seem unpleasant when i want to present the programme to my team members, and having to remove the errors on the spot with a button. I thought of combining my delete cells code and remove reference cell codes together so that they would run simultaneously but to no avail. Is it possible to combine these two codes to achieve my objective or are there any solutions or coding to remove/hide reference errors automatically? Here are the two codes. All of your help would be very much appreciated!
Sub deletetry2()
Dim R As Range
Set rng = Nothing
On Error Resume Next
Set R = Application.InputBox("Select cells To be deleted", Type:=8)
If TypeName(R) <> "Range" Then
Exit Sub
Else
R.Delete
End If
End Sub
Sub Check_ReferenceDeletecolumn()
Dim rng As Range
Dim rngError As Range
Set rng = Sheets("Sheet3").Range("A1:G100")
On Error Resume Next
Set rngError = rng.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rngError Is Nothing Then
rngError.EntireColumn.Delete
'delete means cells will move up after deleting that entire row
End If
End Sub
If the objective is to remove all rows containing errors, from a user defined range, this should work:
Option Explicit
Public Sub cleanUserDefinedRange()
Dim response As Range
On Error Resume Next
Set response = Application.InputBox("Select range to clean up errors", Type:=8)
If Not response Is Nothing Then cleanUpErrors response
On Error GoTo 0
End Sub
'------------------------------------------------------------------------------------------
Private Sub cleanUpErrors(ByRef rng As Range)
Application.ScreenUpdating = False
rng.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Wait for external data to load before automatic calculations? Excel/VBA

First time poster, been searching for a solution to this all over but no luck yet.
To explain my problem:
TERMS:
OPC = Object Linking and Embedding (OLE) for Process Control
(allows other applications to use data from PLC tags)
PLC = Programmable Logic Controller (computer for process control
SCADA = Supervisory Control And Data Acquisition (interface that displays values from PLC and allows control)
I have an excel workbook which is automatically opened by the SCADA system (WonderWare > Intouch, the software) at a specific time after the PLC has sorted some values. This workbook populates its cells using the OPC client, accessing them using this method:
=OPCLINK|EAST!'r[BELLWWPOWER]DailyValues_Z3[1,21]'
This works well but there are a lot of cells to populate so it takes a few seconds.
What I want to automatically happen is for these cells to populate and any calculations to complete before all the cells with formulas are changed to just the values of those formulas. The workbook is then saved under a new workbook name ("PowerReports-YesterdaysDate") with the VBA code stripped and both workbooks are closed (without saving the original, to preserve formulas).
This all works well except it happens too fast and the new saved copy ends up having just "#N/A" in all the cells with OPC links. When I had the first sheet's private sub as "Worksheet_Activate()" instead of "Worksheet_Calculate()", the code wouldn't stat automatically and waited for a mouse click onto one of the sheet's cells (FYI: the SCADA system opens this workbook to sheet 1 automatically to start with sheet 1's code). The new copy would save successfully in this case, but when the code stats automatically it is too fast. How can I wait for the external data to load before the calculations are done?
I've tried things (I don't know how successfully they were implemented..) like:
-Application.Calculate
-Application.RefreshAll
-Timers
-Trying to get a flag from the PLC
-Checking for remaining #N/As
It seems like if a loop or something similar is running right away it doesn't let the external data refresh.
Private Sub Worksheet_Calculate()
' When first sheet "Main" is activated, all formulas are replaced
' with their calculated values. The second sheet, "Monthly Values" is then activated
Dim rng As Range, r As Range
Set rng = Range("A1:D52")
For Each r In rng
If r.HasFormula Then
r.Value = r.Value
End If
Next r
Worksheets("Monthly Data").Activate
End Sub
Private Sub Worksheet_Activate()
' When second sheet "Monthly Values" is activated, all formulas are replaced
' with their calculated values. The sub routine, "SaveWithoutMacros" is then called
Dim rng As Range, r As Range
Set rng = Range("A1:BJ84")
'Worksheets("Monthly Data").Calculate
'If Not Application.CalculationState = xlDone Then
'DoEvents
'End If
For Each r In rng
If r.HasFormula Then
r.Value = r.Value
End If
Next r
Call SaveWithoutMacros
End Sub
Sub SaveWithoutMacros()
'Purpose : To save a copy of the active workbook without macros
Dim vFilename As String
Dim wbActiveBook As Workbook
'----------------------------------------------------------------------
'Following two lines causes an error in Excel 97 - comment them out
Dim VBComp As VBIDE.VBComponent
Dim VBComps As VBIDE.VBComponents
'----------------------------------------------------------------------
' Save to filename in format (yesterdays date) "PowerReports-DD-MM-YYYY"
vFilename = ("D:\PowerReports\" & "PowerReport-" _
& Format(Date - 1, "DD-MMM-YYYY") & ".xls")
ActiveWorkbook.SaveCopyAs vFilename
Set wbActiveBook = Workbooks.Open(vFilename)
'Now strip all VBA, modules, userforms from the copy
'This code is from Chip Pearson's website http://www.cpearson.com
Set VBComps = wbActiveBook.VBProject.VBComponents
For Each VBComp In VBComps
Select Case VBComp.Type
Case vbext_ct_StdModule, vbext_ct_MSForm, vbext_ct_ClassModule
VBComps.Remove VBComp
Case Else
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next VBComp
wbActiveBook.Save ' saves new version after code is stripped
ThisWorkbook.Saved = True ' sets save flag to true, does not actually save
Application.Quit ' quits entire application, all workbooks
End Sub
Sorry for the lengthy post, saw other people getting ripped on for not being detailed enough, haha.
This should work for you now , by testing only the last cell being filled in then you will be sure all the data is in before you change them to values
Were basically telling worksheet_calculate to do nothing until the last cell has a formula
NOTE : SEE OP ANSWER BELOW FOR MODIFIED CODE THAT WORKED IN THIS SCADA SITUATION
Private Sub Worksheet_Calculate()
Dim rngLastCell As Range
Set rngLastCell = Range("D52")
If rngLastCell.HasFormula Then
Dim rng As Range, r As Range
Set rng = Range("A1:D52")
For Each r In rng
If r.HasFormula Then
r.Value = r.Value
End If
Next r
Worksheets("Monthly Data").Activate
End If
End Sub
Ended up getting it! Thanks to Steven Martin for giving me a jump off point to get this working, until you you posted your answer I didn't think an if statement would work for me here without a loop.
This is what worked for me:
Private Sub Worksheet_Calculate()
Dim rngLastCell As Range
Set rngLastCell = Range("D52")
If WorksheetFunction.IsNA(rngLastCell) = False Then
Dim rng As Range, r As Range
Set rng = Range("A1:D52")
For Each r In rng
If r.HasFormula Then
r.Value = r.Value
End If
Next r
Worksheets("Monthly Data").Activate
End If
End Sub
And then the same IF statement checking for "#N/A" in the 2nd sheet's code too, works like a charm now.