I have code on a userform that contains several checkboxes and several DTPickers.
The code looks like so:
Private Sub CheckBox11_Click()
If CheckBox11.Value = True Then
DTPicker22.Enabled = True
Else
DTPicker22.Enabled = False
End If
End Sub
Private Sub CheckBox12_Click()
If CheckBox12.Value = True Then
DTPicker24.Enabled = True
Else
DTPicker24.Enabled = False
End If
End Sub
The Userform contains a lot of checkboxes that have clauses next to them. Upon their completion the DTPicker will enable entering the date of completion.
Whilst this does what I want, it only enables one DTPicker when the checkbox is ticked per private sub. There has to be some way to make this so I wouldn't need to create different private subs for every checkbox click event.
Could you also tell me where to put it, as in, what event?
A "control array" is the typical approach for something like this.
See:
http://www.siddharthrout.com/index.php/2018/01/15/vba-control-arrays/
eg:
Class module clsEvents
Option Explicit
'Handle events for a checkbox and a date control, associated with a worksheet cell
Private WithEvents m_CB As MSForms.CheckBox
Private WithEvents m_DP As DTPicker
Private m_dateCell As Range
'set up the controls and the cell
Public Sub Init(cb As MSForms.CheckBox, dp As DTPicker, rng As Range)
Set m_CB = cb
Set m_DP = dp
Set m_dateCell = rng
If rng.Value > 0 Then
cb.Value = True
m_DP.Value = rng.Value
Else
cb.Value = False
End If
m_DP.CustomFormat = "dd/MM/yyyy"
End Sub
Private Sub m_CB_Change()
m_DP.Enabled = (m_CB.Value = True)
End Sub
Private Sub m_DP_Change()
m_dateCell.Value = m_DP.Value 'update the cell
End Sub
Userform:
Option Explicit
Dim colObj As Collection 'needs to be a Global to stay in scope
Private Sub UserForm_Activate()
Dim obj As clsEvents, i As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set colObj = New Collection
'loop over controls and create a class object for each set
' 3 pairs of controls on my test form...
For i = 1 To 3
Set obj = New clsEvents
obj.Init Me.Controls("CheckBox" & i), _
Me.Controls("DTPicker" & i), _
ws.Cells(i, "B")
colObj.Add obj
Next i
End Sub
The first thing I'd recommend is following a proper naming convention. "CheckBox11" and "DTPciker1" are really vague and once you get further into your code, you'll forget which control is which. I would recommend naming them something that relates the two control together, like "firstDate" and "firstDateDTP". My alternate answer below uses this approach.
You could make a public function that enables the DTPicker based upon the checkbox's value.
Public Function EnableDTPicker(myPicker as String, enableBool as Boolean)
UserFormName.Controls(myPicker).Enabled = enableBool
End Function
Then, you can call the function in your CheckBox123_Click() subs like this:
Private Sub CheckBox123_Click()
EnableDTPicker("thePickerName", CheckBox123.Value)
End Sub
Alternatively, you could make a timer event that runs x number of seconds that just loops through the controls and performs the checks as needed. See this page on how to set up the timer. Using the code in the link shown, You could do something along the lines of:
'Put this in Workbook events
Private Sub Workbook_Open()
alertTime = Now + TimeValue("00:00:01")
Application.OnTime alertTime, "EventMacro"
UserForm1.Show
End Sub
'Put this in a Module
Public Sub EventMacro()
With UserForm1
For each ctrl in .Controls
If TypeName(ctrl) = "CheckBox" Then
'The code below assumes the naming convention outlined above is followed
.Controls(ctrl.Name & "DTP").Enabled = ctrl.Value
End If
Next ctrl
End With
alertTime = Now + TimeValue("00:00:01")
Application.OnTime alertTime, "EventMacro"
End Sub
Related
I have an ActiveX Combobox in one of my main sheet which control/update a series of charts.
Private Sub cmBoxSelect_GotFocus()
Application.ScreenUpdating = False
With Me.cmBoxSelect
.List = Array("Grand Total", "Prod1", "Prod2", "Prod3", "Prod4", "Prod5")
.ListRows = 6
.DropDown
End With
Application.ScreenUpdating = True
End Sub
Private Sub cmBoxSelect_Change()
'series of codes which manipulates the charts, based on selection...
End Sub
I noticed that when I click the ComboBox and select one of its content, it leaves a blue highlight on the selection. So to prevent that, I added:
Private Sub cmBoxSelect_DropButtonClick()
Application.ScreenUpdating = False
ActiveCell.Activate
Application.ScreenUpdating = True
End Sub
It successfully removed the highlight.
However, it has a weird drawback. cmbSelect doesn't close automatically once user didn't select anything (once the combobox is active and the user click any cell in the sheet, it doesn't close out). It was working before I added the DropButtonClick event.
Did I missed anything or any wrong steps above? Thanks for your inputs!
EDIT#1
Seems I already found a solution by trial and error. I only added a blank Label and select it to remove the focus out of the ComboBox whenever there is a change. I also changed the DropButtonClick to LostFocus.
Private Sub cmBoxSelect_GotFocus()
Application.ScreenUpdating = False
With Me.cmBoxSelect
.List = Array("Grand Total", "Prod1", "Prod2", "Prod3", "Prod4", "Prod5")
.ListRows = 6
.DropDown
End With
Application.ScreenUpdating = True
End Sub
Private Sub cmBoxSelect_LostFocus()
ActiveCell.Select
End Sub
Private Sub cmBoxSelect_Change()
'series of codes which manipulates the charts, based on selection...
Me.Label1.Select
End Sub
You need to put the SelLength to 0 in multiple events to avoid highlighting:
so:
Me.cmBoxSelect.SelLength = 0
in:
Private Sub cmBoxSelect_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Private Sub cmBoxSelect_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Private Sub cmBoxSelect_LostFocus()
Private Sub cmBoxSelect_DropButtonClick()
Private Sub cmBoxSelect_Change()
Private Sub cmBoxSelect_GotFocus()
(you could add also Me.cmBoxSelect.SelStart = 0 )
Lets try this:
Not Event-triggered by a change, but by the dropbuttonclick
Private Sub changingComboBox(String s)
'series of codes which manipulates the charts, based on selection...
End Sub
Private Sub cmBoxSelect_DropButtonClick()
Dim s As String
s = cmBoxSelect.SelText
If (cmBoxSelect.SelText = cmBoxSelect.Value) Then
cmBoxSelect.Value = ""
cmBoxSelect.Value = s
Else
call changingComboBox(cmBoxSelect.Value)
End If
End Sub
How about that ?
I have a userform (baseUF) that has multiple pages and buttons that all do different things. I have this baseUF being modeless because I want the user to be able to play with the sheet without closing the userform and losing all of the data they input. However, I started having a problem that might be due to the modeless nature of the baseUF.
There are other userforms that can be called from the baseUF. One executes with no issue by double clicking a textbox. However, the other userform is loaded after a button click. Once that button click sub is finished, the baseUF closes after the Exit Sub OR End Sub line. I don't remember this happening in the past and it doesn't happen with any other button click subs.
Does anybody have an idea what the issue could be? I'm pretty lost because I don't have a command to close the baseUF anywhere in that sub. Below is some code to show what is happening:
This sub is connected to a button on the spreadsheet to open the baseUF (the code is in a module).
Sub Button1_Click()
' show the userform
baseUF.Show vbModeless
End Sub
And this is the sub in the baseUF that calls an additional userform (LoadBox) which seems to be the issue.
Private Sub LoadQuery_Click()
' I Dim a bunch of stuff here
' if there are no saved queries, alert the user
If saveSht.Range("B3").Value = "" Then
MsgBox "No saved queries!"
Exit Sub
' if there is only one saved query, add it to the array and pop up the userform that allows for the user to select which save to load
ElseIf saveSht.Range("B4").Value = "" Then
save_names = saveSht.Range("B3").Value
LoadBox.Show
' otherwise, add all of the save names to the array and pop up that userform
Else
save_names = saveSht.Range(saveSht.Range("B3"),saveSht.Range("B3").End(xlDown)).Value
LoadBox.Show
End If
' if the user didn't select a save to load, stop trying to make stuff happen
If load_name = "" Then
' the userform will also close here if this turns out to be true
Exit Sub
End If
' do a bunch of stuff with the selected name here
' and after this line, the userform that contains this code closes
End Sub
EDIT: here is some code showing the two other userforms
This one is the userform with no issue that is called after a textbox is double clicked
Private Sub UserForm_Initialize()
' On start up of this form, populate the listbox with the relevant column names
' Set position
Me.StartUpPosition = 0
Me.Top = baseUF.Top + 0.5 * baseUF.Height - 0.5 * Me.Height
Me.Left = baseUF.Left + 0.5 * baseUF.Width - 0.5 * Me.Width
With FilterSelectionBox
' First grab all of the column names from the main selected table
For i = 0 To baseUF.SelectionBox.ListCount - 1
.AddItem baseUF.SelectionBox.List(i)
Next i
' Then grab all of the column names from the additional tables to be joined
If Not IsVariantEmpty(join_table_cols) Then
For n = 0 To UBound(join_table_cols)
If Not IsEmpty(join_table_cols(n)) Then
For Each col_name In join_table_cols(n)
.AddItem col_name
Next
End If
Next n
End If
End With
End Sub
Private Sub OkButton_Click()
' Initialize the variables
Dim tb As MSForms.TextBox
Dim arr() As String
Dim str As String
' tb is the textbox object that the column names will be pasted in to
Set tb = baseUF.MultiPage1.Pages(baseUF.MultiPage1.Value).Controls(Me.Tag)
' sets the str according to some logic
' This is actually where it gets sent
tb.Value = str
' And close the form
Unload Me
End Sub
And this is the code in the userform with an issue
Private Sub UserForm_Initialize()
' On initialization, populate the combobox with all of the save names present in the spreadsheet
' Set position
Me.StartUpPosition = 0
Me.Top = baseUF.Top + 0.5 * baseUF.Height - 0.5 * Me.Height
Me.Left = baseUF.Left + 0.5 * baseUF.Width - 0.5 * Me.Width
With LoadComb
' If there is more than one save present, go through the array and add each one
If IsArray(save_names) Then
For Each saved_name In save_names
.AddItem saved_name
Next
' Otherwise just add the one
Else
.AddItem save_names
End If
End With
End Sub
Private Sub LoadButton_Click()
' When the user hits the load button, first check if they actually selected anything
If LoadComb.Value = "" Then
' If they didn't, yell at them
MsgBox "No saved query selected!"
Else
' Otherwise, save the name to a global variable
load_name = LoadComb.Value
End If
' Close the form
Unload Me
End Sub
Whenever something unexpected happens with forms, consider writing End in the immediate window and pressing enter. It will kill all the unkilled instances of a form and generally any variable, thus it would be like a cold restart to the VBA program.
After doing this, it is a good idea to consider a cleaner solution, concerning VBA & UserForms, using some OOP. (Disclaimer - the first article is mine):
http://www.vitoshacademy.com/vba-the-perfect-userform-in-vba/
https://rubberduckvba.wordpress.com/2017/10/25/userform1-show/
https://codereview.stackexchange.com/questions/154401/handling-dialog-closure-in-a-vba-user-form
Although it may seem that you are achieving the same results with more code, the benefits of using this approach are quite a lot in the long term.
This is a small example of the OOP model. Imagine you have a user form like this:
It has only the following controls:
btnRun
btnExit
lblInfo
frmMain (the class)
The code withing the form is the following:
Option Explicit
Public Event OnRunReport()
Public Event OnExit()
Public Property Get InformationText() As String
InformationText = lblInfo.Caption
End Property
Public Property Let InformationText(ByVal value As String)
lblInfo.Caption = value
End Property
Public Property Get InformationCaption() As String
InformationCaption = Caption
End Property
Public Property Let InformationCaption(ByVal value As String)
Caption = value
End Property
Private Sub btnRun_Click()
RaiseEvent OnRunReport
End Sub
Private Sub btnExit_Click()
RaiseEvent OnExit
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
Hide
End If
End Sub
The form is with two events, getting caught by the clsSummaryPresenter. The clsSummaryPresenter looks like this:
Option Explicit
Private WithEvents objSummaryForm As frmMain
Private Sub Class_Initialize()
Set objSummaryForm = New frmMain
End Sub
Private Sub Class_Terminate()
Set objSummaryForm = Nothing
End Sub
Public Sub Show()
If Not objSummaryForm.Visible Then
objSummaryForm.Show vbModeless
Call ChangeLabelAndCaption("Press Run to Start", "Starting")
End If
With objSummaryForm
.Top = CLng((Application.Height / 2 + Application.Top) - .Height / 2)
.Left = CLng((Application.Width / 2 + Application.Left) - .Width / 2)
End With
End Sub
Private Sub Hide()
If objSummaryForm.Visible Then objSummaryForm.Hide
End Sub
Public Sub ChangeLabelAndCaption(strLabelInfo As String, strCaption As String)
objSummaryForm.InformationText = strLabelInfo
objSummaryForm.InformationCaption = strCaption
objSummaryForm.Repaint
End Sub
Private Sub objSummaryForm_OnRunReport()
MainGenerateReport
Refresh
End Sub
Private Sub objSummaryForm_OnExit()
Hide
End Sub
Public Sub Refresh()
With objSummaryForm
.lblInfo = "Ready"
.Caption = "Task performed"
End With
End Sub
Finally, we have the modMain, which is the so-called business logic of the form:
Option Explicit
Private objPresenter As clsSummaryPresenter
Public Sub MainGenerateReport()
objPresenter.ChangeLabelAndCaption "Starting and running...", "Running..."
GenerateNumbers
End Sub
Public Sub GenerateNumbers()
Dim lngLong As Long
Dim lngLong2 As Long
tblMain.Cells.Clear
For lngLong = 1 To 10
For lngLong2 = 1 To 10
tblMain.Cells(lngLong, lngLong2) = lngLong * lngLong2
Next lngLong2
Next lngLong
End Sub
Public Sub ShowMainForm()
If (objPresenter Is Nothing) Then
Set objPresenter = New clsSummaryPresenter
End If
objPresenter.Show
End Sub
I have a Excel workbook calculator dependent on a few parameters. I want the client to be able to insert those parameters into an appropriate "client input" cell on every spreadsheet so he doesn't have to jump back and forth between spreadsheets.
Is there a good way to do it? I tried the following scheme, but it's buggy for reasons unknown to me:
make a VBA module declaring variables to hold my parameters
initialize them with appropriate initial values on the Workbook_Open event
make the specific sheets write those values into "client input" cells on Worksheet_Activate event
in a Worksheet_Deactivate event, if the "client input" cells are different among each other - update the VBA variables
This works sometimes, but not always. Is there a better way to do this?
EDIT:
This is my "GM" Module:
Option Explicit
Public perspective As String
Public RSS As String
Public Payback As Double
This is my "ThisWorkbook:
Private Sub Workbook_Open()
GM.perspective = Worksheets("Hidden variables").Range("A1").Value
GM.RSS = Worksheets("Hidden variables").Range("B2").Value
GM.Payback = Worksheets("Hidden variables").Range("C3").Value
End Sub
Private Sub Workbook_Close()
Worksheets("Hidden variables").Range("A1") = GM.perspective
Worksheets("Hidden variables").Range("B2") = GM.RSS
Worksheets("Hidden variables").Range("C3") = GM.Payback
End Sub
This is in my worksheet 1 (in worksheet 2 there is an analogous code):
Option Explicit
Private Sub Worksheet_Activate()
'SIMULTANEOUS UPDATE p.1
Worksheets("1").Range("I32") = GM.Payback
Worksheets("1").Range("I29") = GM.RSS
Worksheets("1").Range("I26") = GM.perspective
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'BASIC PRICE CALCULATION
If Target.Count > 1 Then Exit Sub
If Target = Range("I32") _
Or Target = Range("I29") _
Or Target = Range("I26") _
Or Target = Worksheets("Intro").Range("price") _
Then
Worksheets("Hidden variables").Range("condition") = 2
Worksheets("Hidden variables").Range("basic_price") = Worksheets("Intro").Range("price").Value
Range("M44").GoalSeek Goal:=0, ChangingCell:=Worksheets("Hidden variables").Range("basic_price")
If Worksheets("Hidden variables").Range("basic_price").Value < 0 Then
Range("M46") = "Error"
Else
Range("M46") = Worksheets("Hidden variables").Range("basic_price").Value
End If
Worksheets("Hidden variables").Range("condition") = 1
End If
End Sub
Private Sub Worksheet_Deactivate()
'SIMULTANEOUS UPDATE p.2
GM.Payback = Worksheets("1").Range("I32").Value
GM.RSS = Worksheets("1").Range("I29").Value
GM.perspective = Worksheets("1").Range("I26").Value
End Sub
To avoid infinite loop, you can use a global variable
Outside a function (at the begin of your module)
Public isUpdating As Double
inside your Worksheet_change
Private Sub Worksheet_Change(ByVal Target As Range)
' Check if an update is in progress. If so, exit the change
if isUpdating then
exit sub
end if
' Begin of the update
isUpdating = true
' Here your update
' End of the update
isUpdating = false
End sub
I'm trying to make an Excel Add-In to create a simple button when any workbook is opened, but I'm getting
Object variable or With Block variable not set
I think this is happening because technically there is no 'ActiveWorkbook' yet.
First thing I want to do is delete any buttons currently on the sheet. Then I want to place a button.
Anyone know how to make that happen?
Code
Private Sub Workbook_Open()
ActiveWorkbook.ActiveSheet.Buttons.Delete
Dim CommandButton As Button
Set CommandButton = ActiveWorkbook.ActiveSheet.Buttons.Add(1200, 100, 200, 75)
With CommandButton
.OnAction = "Test_Press"
.Caption = "Press for Test"
.Name = "Test"
End With
End Sub
I then have a Private Sub Test_Press() to display a MsgBox. The button is not being created though.
Credit goes to http://www.jkp-ads.com/Articles/FixLinks2UDF.asp
Note: I have another module I didn't post below, which houses the macro Project_Count I tied to the button I place on the workbook only if the workbook name is TT_GO_ExceptionReport
I also have a VBScript that downloads the Add-In, places it in the users addin folder, and installs it. If you want to know how to do that, leave a comment.
Code of Add-In that solved the problem:
ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
' Purpose : Code run at opening of workbook
'-------------------------------------------------------------------------
'Initialise the application
InitApp
modProcessWBOpen.TimesLooped = 0
Application.OnTime Now + TimeValue("00:00:03"), "CheckIfBookOpened"
End Sub
Module 1 named modInit
Option Explicit
'Create a module level object variable that will keep the instance of the
'event listener in memory (and hence alive)
Dim moAppEventHandler As cAppEvents
Sub InitApp()
'Create a new instance of cAppEvents class
Set moAppEventHandler = New cAppEvents
With moAppEventHandler
'Tell it to listen to Excel's events
Set .App = Application
End With
End Sub
Module 2 named modProcessWBOpen
Option Explicit
'Counter to keep track of how many workbooks are open
Dim mlBookCount As Long
'Counter to check how many times we've looped
Private mlTimesLooped As Long
' Purpose : When a new workbook is opened, this sub will be run.
' Called from: clsAppEvents.App_Workbook_Open and ThisWorkbook.Workbook_Open
'-------------------------------------------------------------------------
Sub ProcessNewBookOpened(oBk As Workbook)
If oBk Is Nothing Then Exit Sub
If oBk Is ThisWorkbook Then Exit Sub
If oBk.IsInplace Then Exit Sub
CountBooks
'This checks to make sure the name of the new book matches what I
'want to place the button on
If oBk.Name = "TT_GO_ExceptionReport.xlsm" Then
Dim CommandButton As Button
Set CommandButton = Workbooks("TT_GO_ExceptionReport.xlsm").Sheets(1).Buttons.Add(1200, 100, 200, 75)
With CommandButton
.OnAction = "Project_Count"
.Caption = "Press for Simplified Overview"
.Name = "Simplified Overview"
End With
End If
End Sub
Sub CountBooks()
mlBookCount = Workbooks.Count
End Sub
Function BookAdded() As Boolean
If mlBookCount <> Workbooks.Count Then
BookAdded = True
CountBooks
End If
End Function
' Purpose : Checks if a new workbook has been opened
' (repeatedly until activeworkbook is not nothing)
'-------------------------------------------------------------------------
Sub CheckIfBookOpened()
If BookAdded Then
If ActiveWorkbook Is Nothing Then
mlBookCount = 0
TimesLooped = TimesLooped + 1
'May be needed if Excel is opened from Internet explorer
Application.Visible = True
If TimesLooped < 20 Then
Application.OnTime Now + TimeValue("00:00:01"), "CheckIfBookOpened"
Else
TimesLooped = 0
End If
Else
ProcessNewBookOpened ActiveWorkbook
End If
End If
End Sub
Public Property Get TimesLooped() As Long
TimesLooped = mlTimesLooped
End Property
Public Property Let TimesLooped(ByVal lTimesLooped As Long)
mlTimesLooped = lTimesLooped
End Property
Class Module named cAppEvents
' Purpose : Handles Excel Application events
'-------------------------------------------------------------------------
Option Explicit
'This object variable will hold the object who's events we want to respond to
Public WithEvents App As Application
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
'Make sure newly opened book is valid
ProcessNewBookOpened Wb
End Sub
Private Sub Class_Terminate()
Set App = Nothing
End Sub
something like this?
Option Explicit
Sub Button()
Dim cButton As Button
Dim rng As Range
Dim i As Long
ActiveSheet.Buttons.Delete
For i = 2 To 3 Step 2
Set rng = ActiveSheet.Range(Cells(i, 2), Cells(i, 2))
Set cButton = ActiveSheet.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
With cButton
.OnAction = "Test_Press"
.Caption = "Press for Test " & i
.Name = "Test" & i
End With
Next i
End Sub
See Example here
I have a macro code behind Worksheet. When button is clicked on the sheet, new user form is initialised and showed to user. If user closes the windows with red X, or form is closed with "hide" function/method, all global variables that are behind Worksheet loses their values. Is it possible to preserve this values?
Worksheet code behind:
Private MeasurementCollection As Collection
Dim CurrentMeasurement As measurement
Dim NewMeasurement As measurement
Private Sub Worksheet_Activate()
Initialize
End Sub
Public Sub Initialize()
Set NewMeasurement = New measurement
Dim DropDownDataQueries As Collection
Set DropDownDataQueries = DBQueries.GetAllUpdateQueries
For i = 1 To DropDownDataQueries.Count
Dim Values As Collection
Set Values = DataBase.GetData(DropDownDataQueries(i))
With Me.OLEObjects("Combo" & i).Object
For Each value In Values
.AddItem value
Next value
End With
Next i
End Sub
Private Sub UpdateDB_Click()
UpdateGeneralData
If (CurrentMeasurement Is Nothing) Then
MsgBox ("Message text")
Else
Dim form As UpdateComentForm
Set form = New UpdateComentForm
form.Show
End If
End Sub
Private Sub Combo1_Change()
If Application.EnableEvents = True Then
If (Combo1.value <> "") Then
NewMeasurement.DN = Combo1.value
Else
NewMeasurement.DN = 0
End If
End If
End Sub
UserForm code
Private Sub UpdateDBData_Click()
If (Komentar.value <> "") Then
Me.Hide
Else
MsgBox ("Prosimo napiĊĦite vzrok za spremembe podatkov v belo polje!")
End If
End Sub
Private Sub UserForm_Terminate()
Me.Hide
End Sub
Experiments show that the module-level variables are cleared upon exiting a procedure that involves calling = New Form, provided that the form designer window is opened somewhere in the IDE.
Close all user forms designer windows you might have open in the VBA IDE and try again.
NewMeasurement as been declared but never assigned.
You could do something like Dim NewMeasurement As New measurement to create an instance of the object.