Excel VBA Userform CheckBox check mark does not appear - vba

I have created an UserForm in Excel. The UserForm has a ListBox and a CheckBox added to it.
I have written VBA code to populate the ListBox with data in the 1st column of the UserForm_Data worksheet. I am attempting to add a Select All CheckBox to the UserForm. When I click on the CheckBox once, the check mark does not appear but the If Me.CheckBox.Value = True section of the Checkbox1_Change event is executed and all the items in the ListBox are selected. The check mark appears only when I click the CheckBox the second time. The Excel VBA code and an image of the UserForm are attached.
Option Explicit
Private Sub ListBox1_Change()
Dim i As Long
If CheckBox1.Value = True Then
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = False Then
Me.CheckBox1.Value = False
End If
Next i
End If
End Sub
Private Sub CheckBox1_Change()
Dim i As Long
If Me.CheckBox1.Value = True Then
With Me.ListBox1
For i = 0 To .ListCount - 1
.Selected(i) = True
Next i
End With
Else
i = 0
End If
End Sub
Private Sub UserForm_Initialize()
Dim rng1 As Range
Dim ws1 As Worksheet
Dim i, lastRow As Long
Dim list1 As Object
Dim string1 As String
Dim array1 As Variant
Set list1 = CreateObject("System.Collections.ArrayList")
Set ws1 = ThisWorkbook.Worksheets("UserForm_data")
lastRow = ws1.UsedRange.Rows.Count
Me.ListBox1.Clear
For i = 2 To lastRow
string1 = CStr(ws1.Cells(i, 1).Value)
If Not list1.Contains(string1) Then
list1.Add string1
End If
Next i
array1 = list1.ToArray
Me.Caption = "UserForm1"
Me.ListBox1.list = array1
Me.ListBox1.MultiSelect = 1
Me.CheckBox1.Value = False
End Sub

There are two steps you can take to address this:
There's a chance that simply adding a DoEvents at the end of the CheckBox1_Change event will force the redraw.
If that doesn't work, add the following line just above the DoEvents and test it again... this encourages a screen update...
Application.WindowState = Application.WindowState

One approach is to use global flags to toggle on and off the control event handlers. Here is what the updated events would look like:
Option Explicit
Private Sub ListBox1_Change()
Dim i As Long
If Not AllowListBoxEvents Then Exit Sub
AllowCheckBoxEvents = False
If CheckBox1.Value = True Then
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = False Then CheckBox1.Value = False
Next i
End If
AllowCheckBoxEvents = True
End Sub
Private Sub CheckBox1_Change()
Dim i As Long
If Not AllowCheckBoxEvents Then Exit Sub
AllowListBoxEvents = False
If CheckBox1.Value = True Then
For i = 0 To ListBox1.ListCount - 1
ListBox1.Selected(i) = True
Next i
End If
AllowListBoxEvents = True
End Sub
Make sure you set the "Allow" variables to True in the Initialize event.

Related

Userform initialize checks then close

I have a userform. The idea is to check if there are any 'True' values in column(15) in 'Admin' sheet. If there is at least a single 'True' value, then the userform will remain open and continue its operation.
However, if there is not a single 'True' found, then the userform will display a message and close the userform automatically.
Private Sub Userform_initialize()
Dim LR As Long
LR = Sheets("Project_Name").Cells(Rows.Count, "B").End(xlUp).Row
With Worksheets("Admin")
For i = 7 To LR
If .Cells(i, 15) = "True" Then
Exit For
Else
MsgBox ("No values found")
Exit For
Unload Me
End If
Next i
End With
''' more code'''
End Sub
Everything on my userform works as expected, except for the fact I am unable to make it close itself automatically. I.e. Unload Me is not working.
Any advice?
You should check your criteria before you even display the UserForm. You can add this as a condition wherever you are calling the UserForm. No need to open the form just to immediately close it when you can check before-hand.
On the first instance of True, the UserForm will open, and exit the sub. If the loop completes (finds no True values), the sub will proceed to your MsgBox
Sub OpenForm
With Worksheets("Admin")
For i = 7 To LR
If Cells(i,15) = "True" then
Userform.Show
Exit Sub
End If
Next i
End With
MsgBox "No Values Found"
End Sub
Please look at your code; you have put Unload Me is after Exit For
'Here is something for you to ponder on .........
'Public enum type to add a set of particular vbKeys to the standard key set
Public Enum typePressKeys
vbNoKey = 0
vbExitTrigger = -1
vbAnswerKey = 100
vbLaunchKey = 102
vbPrevious = 104
vbNext = 106
vbSpecialAccessKey = 108
End Enum
Public Sub doSomethingWithMyUserform()
Dim stopLoop As Boolean, testVal As Boolean, rngX As Range, LR As Long
LR = ThisWorkbook.Sheets("Project_Name").Cells(Rows.Count, "B").End(xlUp).Row
Set rngX = ThisWorkbook.Worksheets("Admin")
testVal = False
With rngX 'Your sub can do the check here
For i = 7 To LR
If .Cells(i, 15) = "True" Then
testVal = True
Exit For
End If
Next i
End With
If testVal Then
Load UserForm1
With UserForm1
.Caption = "Something"
.Tag = vbNoKey
.button_OK.SetFocus 'Assuming you have a OK button on Userform1
End With
UserForm1.Show
stopLoop = False
Do
If UserForm1.Tag = vbCancel Then
'Do something perhaps
Unload UserForm1
stopLoop = True
ElseIf UserForm1.Tag = vbOK Then
'Do something specific
Unload UserForm1
stopLoop = True
Else
stopLoop = False
End If
Loop Until stopLoop = True
else
MsgBox "No values found"
End If
'Here you can close the way you want
Set rngX = Nothing
End Sub
enter code here

VBA - Loop Option Buttons & Check Boxes on a UserForm

I am trying to display specific data in a specific worksheet using a user form.
There is one command button on the user form - Next - that takes the users preferences (option button chosen), opens a new workbook, and displays the desired data (check boxes chosen) in the specific workbook.
There are 6 option buttons and and 6 check boxes. The worksheet that opens is based on the option button preference and depending on what was chosen in the check boxes, the data associated to that topic will display in the worksheet.
How can i loop options buttons and check boxes on a userform and capture which are "selected"?
The data displayed (in a worksheet) from the chosen check boxes depends on the option button chosen e.g. if I chose Finance (option button), and then I chose Photos and Videos (check boxes), I'd like to display data specific to those selections on the appropriate worksheet.
Here is what I have so far:
Private Sub cmdNext_Click()
'declare variables
Dim strFinancial As String, strFamily As String, strSadness As String,
strSchool As String, strRelationship As String, strTime As String
Dim shtFinancial As Worksheet, shtFamily As Worksheet, shtSadness As
Worksheet, shtSchool As Worksheet, shtRelationship As Worksheet,
shtTime As Worksheet, shtData As Worksheet
shtFinancial = Workbooks("PROJECT.xlsm").Worksheets("Financial")
shtTime = Workbooks("PROJECT.xlsm").Worksheets("Time")
shtFamily = Workbooks("PROJECT.xlsm").Worksheets("Family")
shtSadness = Workbooks("PROJECT.xlsm").Worksheets("Sadness")
shtSchool = Workbooks("PROJECT.xlsm").Worksheets("School")
shtRelationship = Workbooks("PROJECT.xlsm").Worksheets("Relationship")
shtData = Workbooks("PROJECT.xlsm").Worksheets("Data")
'set option button selection to string
strFinancial = obFinancial.Value
strFamily = obFamily.Value
strSadness = obSadness.Value
strSchool = obSchool.Value
strRelationship = obRelationship.Value
strTime = obTime.Value
'activate worksheet of chosen stressor (option button)
Select Case True
Case strTime = True
shtTime.activate
Case strFinancial = True
shtFinancial.activate
Case strFamily = True
shtFamily.activate
Case strSadness = True
shtSadness.activate
Case strSchool = True
shtSchool.activate
Case strRelationship = True
shtRelationship.activate
End Select
'ADVICE
'loop through checkboxes HOW ????
'display advice according to option button chosen
If obFinancial.Value = True And Me.cbAdvice.Value = True Then
shtData.Range("A1:A10").Copy Destination:=Sheets("Financial").Range("A1:A10")
End If
If obSadness.Value = True And Me.cbAdvice.Value = True Then
Sheets("Data").Range("A21:A30").Copy Destination:=Sheets("Sadness").Range("A1:A10")
End If
If obSchool.Value = True And Me.cbAdvice.Value = True Then
Sheets("Data").Range("A31:A40").Copy Destination:=Sheets("School").Range("A1:A10")
End If
If obRelationship.Value = True And Me.cbAdvice.Value = True Then
Sheets("Data").Range("A41:A50").Copy Destination:=Sheets("Relationship").Range("A1:A10")
End If
If obTime.Value = True And Me.cbAdvice.Value = True Then
Sheets("Data").Range("A51:A60").Copy Destination:=Sheets("Time").Range("A1:A10")
End If
End Sub
Here is the userform:
Yes, it's little bit unclear what you trying to do...
Following is a general example how you might loop through CheckBoxes and OptionButtons:
Private Sub CommandButton1_Click()
Dim c As Control, str As String
For Each c In UserForm1.Controls
If TypeName(c) = "CheckBox" Or TypeName(c) = "OptionButton" Then
str = str & IIf(c = True, c.Caption & vbCrLf, "")
End If
Next c
MsgBox "Selected controls" & vbCrLf & str
End Sub
It is a little difficult to see exactly what you want but I can't help wondering if you're looking at VBA in the wrong way. VBA is an event-driven language, meaning that you can capture most interactions the user has with your programme. This should do away with the need to loop through your controls each time, as you could just log selections as the user makes them.
The most obvious thing to do would be to create some kind of sheet/range map, say in a Collection, and then just retrieve the objects you want based on a selection key. The code below is a skeleton of how you could do it - obviously you'd need to expand and adjust it to suit your own needs.
First declare a few variables at module-level (ie very top of your page):
Option Explicit
Private mRangeMap As Collection
Private mOptKey As String
Private mCboxKey As String
Then build your map. In the example below, I've done this in the Userform_Initialize routine, but you could call it anywhere:
Private Sub UserForm_Initialize()
Dim shtRngPair(1) As Object
'Build the range map.
Set mRangeMap = New Collection
With ThisWorkbook 'use name ofyour workbook
Set shtRngPair(0) = .Worksheets("Financial")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A1:A10")
mRangeMap.Add shtRngPair, "Fin|Adv"
Set shtRngPair(1) = .Range("A11:A20")
mRangeMap.Add shtRngPair, "Fin|Pho"
End With
Set shtRngPair(0) = .Worksheets("Sadness")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A21:A30")
mRangeMap.Add shtRngPair, "Sad|Adv"
Set shtRngPair(1) = .Range("A31:A40")
mRangeMap.Add shtRngPair, "Sad|Pho"
End With
Set shtRngPair(0) = .Worksheets("School")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A41:A50")
mRangeMap.Add shtRngPair, "Sch|Adv"
Set shtRngPair(1) = .Range("A51:A60")
mRangeMap.Add shtRngPair, "Sch|Pho"
End With
End With
End Sub
Now you just need the code to store the user inputs. I just have 3 option buttons and 2 checkboxes for an example:
Private Sub cboxAdvice_Click()
mCboxKey = "Adv"
End Sub
Private Sub cboxPhotos_Click()
mCboxKey = "Pho"
End Sub
Private Sub obFinancial_Click()
mOptKey = "Fin"
End Sub
Private Sub obSadness_Click()
mOptKey = "Sad"
End Sub
Private Sub obSchool_Click()
mOptKey = "Sch"
End Sub
Finally, copy the data when the user hits the Next button:
Private Sub cmdNext_Click()
Dim key As String
Dim shtRngPair As Variant
Dim v As Variant
'Create the key
key = mOptKey & "|" & mCboxKey
'Find the relevant range
On Error Resume Next
shtRngPair = mRangeMap(key)
On Error GoTo 0
'Test if the key is valid
If IsEmpty(shtRngPair) Then
MsgBox "Selection [" & key & "] is invalid."
Exit Sub
End If
'Copy the data
v = shtRngPair(1).Value2
With shtRngPair(0)
.Cells.Clear
.Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
.Activate
End With
End Sub
Update as per OP's comment
Below is the updated code which iterates your checkbox selections. You'd need to add additional code if you wanted them in a specific order:
Option Explicit
Private mRangeMap As Collection
Private mCboxKeys As Collection
Private mOptKey As String
Private Sub cboxAdvice_Change()
UpdateCheckboxList "Adv", cboxAdvice.Value
End Sub
Private Sub cboxPhotos_Change()
UpdateCheckboxList "Pho", cboxPhotos.Value
End Sub
Private Sub UpdateCheckboxList(ele As String, addItem As Boolean)
'Add or remove the item
If addItem Then
mCboxKeys.Add ele, ele
Else
mCboxKeys.Remove ele
End If
End Sub
Private Sub obFinancial_Click()
mOptKey = "Fin"
End Sub
Private Sub obSadness_Click()
mOptKey = "Sad"
End Sub
Private Sub obSchool_Click()
mOptKey = "Sch"
End Sub
Private Sub cmdNext_Click()
Dim key As String
Dim shtRngPair As Variant, v As Variant, cbk As Variant
Dim rng As Range
Dim initialised As Boolean
For Each cbk In mCboxKeys
'Create the key
key = mOptKey & "|" & cbk
'Find the relevant range
On Error Resume Next
shtRngPair = mRangeMap(key)
On Error GoTo 0
If IsEmpty(shtRngPair) Then
'Test if the key is valid
MsgBox "Selection [" & key & "] is invalid."
Else
If Not initialised Then
With shtRngPair(0)
.Cells.Clear
.Activate
Set rng = .Range("A1")
End With
initialised = True
End If
'Copy the data
v = shtRngPair(1).Value2
rng.Resize(UBound(v, 1), UBound(v, 2)).Value = v
'Offset range
Set rng = rng.Offset(UBound(v, 1))
End If
Next
End Sub
Private Sub UserForm_Initialize()
Dim shtRngPair(1) As Object
'Initialise the collections
Set mRangeMap = New Collection
Set mCboxKeys = New Collection
'Build the range map.
With ThisWorkbook 'use name ofyour workbook
Set shtRngPair(0) = .Worksheets("Financial")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A1:A10")
mRangeMap.Add shtRngPair, "Fin|Adv"
Set shtRngPair(1) = .Range("A11:A20")
mRangeMap.Add shtRngPair, "Fin|Pho"
End With
Set shtRngPair(0) = .Worksheets("Sadness")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A21:A30")
mRangeMap.Add shtRngPair, "Sad|Adv"
Set shtRngPair(1) = .Range("A31:A40")
mRangeMap.Add shtRngPair, "Sad|Pho"
End With
Set shtRngPair(0) = .Worksheets("School")
With .Worksheets("Data")
Set shtRngPair(1) = .Range("A41:A50")
mRangeMap.Add shtRngPair, "Sch|Adv"
Set shtRngPair(1) = .Range("A51:A60")
mRangeMap.Add shtRngPair, "Sch|Pho"
End With
End With
End Sub

Simplify code with loop

Hi I'm pretty new at the vba so please don't shoot my code :-).
I have a set of repaeting code's. I woukld like to simplify this code by using the code name with an increasing number. I can't get it to run. Can someone help me a bit on the road to get this going.
Below what I'm trying.
The second block is a part of the code now (it's 40 blocks of the same code only increasing the number)
Sub sheet41()
Dim i As Integer
Dim chkname As Integer
chkname = "SheetCheckBox" & i
i = 1
Do
i = i + 1
If chkname.Visible = False Then Exit Sub
If chkname.value = True Then
Sheets("Item_" & i).Select
Call Finalize
End If
Loop Until i = ThisWorkbook.Worksheets.Count
End Sub
This is the old code:
Sub Sheet1()
If SheetCheckBox1.Visible = False Then Exit Sub
If SheetCheckBox1.value = True Then
Sheets("Item_1").Select
Call Finalize
End If
End Sub
Sub Sheet2()
If SheetCheckBox2.Visible = False Then Exit Sub
If SheetCheckBox2.value = True Then
Sheets("Item_2").Select
Call Finalize
End If
End Sub
Sub Sheet3()
If SheetCheckBox3.Visible = False Then Exit Sub
If SheetCheckBox3.value = True Then
Sheets("Item_3").Select
Call Finalize
End If
End Sub
As you can see this should be possible to clean I asume.
This should do it. If finalize isn't called on a worksheet then the reason why is printed to the Immediate Window.
Sub ProcessWorkSheets()
Dim check As MSForms.CHECKBOX
Dim i As Integer
For i = 1 To Worksheets.Count
On Error Resume Next
Set check = Worksheets(i).OLEObjects("SheetCheckBox" & i).Object
On Error GoTo 0
If check Is Nothing Then
Debug.Print Worksheets(i).Name; " - Checkbox not found"
Else
If check.Visible And check.Value Then
Worksheets(i).Select
Call Finalize
Else
Debug.Print Worksheets(i).Name; " - Checkbox", "Visible", check.Visible, "Value:", check.Value
End If
End If
Set check = Nothing
Next
End Sub
If the checkboxes on the Sheet are ActiveX Controls, you can use this to access the checkboxes:
Sheets("sheet1").OLEObjects("chkTest").Object
if you want to change the value of a checkbox, use it like this:
Sheets("sheet1").OLEObjects("chkTest").Object.Value = True
now replace "sheet1" with your actual sheet name and change the "chkTest" to your string chkname
So your complete code should be like this:
Dim i As Integer
Dim sheetname As String
Dim chkname As String
sheetname = "YOUR SHEETNAME HERE"
For i = 1 To ThisWorkbook.Worksheets.Count Step 1
chkname = "SheetCheckBox" & i
If Sheets(sheetname).OLEObjects(chkname).Object.Visible = False Then Exit Sub
If Sheets(sheetname).OLEObjects(chkname).Object.Value = True Then
Sheets("Item_" & i).Select
Call Finalize
End If
Next i

VBA Refresh UserForm ListBox Data when source changes

Hi I have encountered problem with my listbox data in my Userform
When I try to change the source file where my listbox connected it doesn't seems to change
It was showing good data at first but when I try to click RUN DATE button
It doesn't go with the Value in my Range that is being set as My key for sorting
Here is my code for RUN DATE BUTTON for sorting Ascending and Descending
Private Sub CommandButton1_Click()
Application.EnableEvents = False
Worksheets("combobox_value").Activate
Dim strDataRange As Range
Dim keyRange As Range
Set strDataRange = Range("I2:L4")
Set keyRange = Range("I2:I4")
If Range("M2").Value = "D" Then
strDataRange.Sort Key1:=keyRange, Order1:=xlDescending
Range("M2").Value = "A"
Else
strDataRange.Sort Key1:=keyRange, Order1:=xlAscending
Range("M2").Value = "D"
End If
Application.EnableEvents = True
End Sub
And this is how I initialize the value in my listbox
Private Sub UserForm_Initialize()
'set ListBox properties on initialization of UserForm
Set sht = ThisWorkbook.Worksheets("combobox_value")
lastRow_combobox_column = sht.Cells(sht.Rows.Count, "I").End(xlUp).Row
With ListBox1
.ColumnCount = 4
.ColumnWidths = "100"
.ColumnHeads = False
.ControlTipText = True
End With
'Load Worksheet Range directly to a ListBox:
Dim var As Variant
var = Sheets("combobox_value").Range("I2:L" & lastRow_combobox_column)
Me.ListBox1.List = var
End Sub
Is there a way to refresh my listbox? Listbox1.refresh something like that?
Note: I don't need to close my Userform and open again to see the updated listbox
so while the Userform is in active mode(Open) I can directly update the listbox value..
Thanks
Instead of using var and assigning the data to List from var, you can use Named Range of data in the sheet and assign the property
ListBox1.RowSource = "Name of the Range"
Every time you want to refresh the listbox just use the above assignment in your code and it will work. If you find any difficulty please let me know.
You could add a refresh procedure, then call it in your OnClick event procedure for the button.
Note, I haven't tested this code, but it should do what your original question asked.
Private Sub UserForm_Initialize()
'set ListBox properties on initialization of UserForm
Set sht = ThisWorkbook.Worksheets("combobox_value")
lastRow_combobox_column = sht.Cells(sht.Rows.Count, "I").End(xlUp).Row
With ListBox1
.ColumnCount = 4
.ColumnWidths = "100"
.ColumnHeads = False
.ControlTipText = True
End With
RefreshListbox
End Sub
Private Sub CommandButton1_Click()
Application.EnableEvents = False
Worksheets("combobox_value").Activate
Dim strDataRange As Range
Dim keyRange As Range
Set strDataRange = Range("I2:L4")
Set keyRange = Range("I2:I4")
If Range("M2").Value = "D" Then
strDataRange.Sort Key1:=keyRange, Order1:=xlDescending
Range("M2").Value = "A"
Else
strDataRange.Sort Key1:=keyRange, Order1:=xlAscending
Range("M2").Value = "D"
End If
Application.EnableEvents = True
RefreshListbox
End Sub
Private Sub RefreshListbox()
Me.ListBox1.Clear
'Load Worksheet Range directly to a ListBox:
Dim ListRange As Range
ListRange = Sheets("combobox_value").Range("I2:L" & lastRow_combobox_column)
Me.ListBox1.List = ListRange
End Sub

How to display Values from a multiselect listbox

I have a form in Excel macro. This form will capture the values inserted in textboxes, listbox and store in Sheet2.
There are 2 buttons in the form applet named "Next" and "Previous". These button will be used for navigating between the saved records. I am able to navigate between records and the values display fine in textboxes. However, I am not sure how can I display the Values from listboxes. My list box is a multiselect list box.
I have provided snippet of my code on how the records are saved in sheet2 and how the navigation happens when clicked on Next button.
Private Sub Save_Click()
Dim ctl As Control
Dim S As String
Dim i As Integer
RowCount = Worksheets("Sheet2").Range("A1").CurrentRegion.Rows.Count
With Worksheets("Sheet2").Range("A1")
.Offset(RowCount, 0).Value = Me.Name1.Value ' capture value from list box
'below code is for capturing value from multiselect listbox
With AOI
For i = 0 To .ListCount - 1
If .Selected(i) = True Then S = S & ", " & .List(i)
Next i
Range("A1").Offset(RowCount, 10).Value = S
End With
End Sub
Below code is for navigating between saved records..
Private Sub Next1_Click()
strCurrentSetofRows = Worksheets("Sheet2").Range("A1").CurrentRegion.Rows.Count
i = i + 1: j = 0
If i > (strCurrentSetofRows - 1) Then
MsgBox "No More Records"
Exit Sub
End If
Set sRange = Worksheets("Sheet2").Range("A1")
Name1.Text = sRange.Offset(i, j).Value: j = j + 1
End Sub
Any thoughts on how can I display saved values of AOI (my field).
Since you are storing the values using , as a separator, you can use the same to split the values and upload it to the ListBox. BTW, I hope you are generating the ListBox with the complete list in the UserForm's Initialize event?
Here is a very basic example. Please amend it to suit your needs.
Let's say Cell A1 has Blah1,Blah2,Blah6. Then try this code
Option Explicit
Dim i As Long, j As Long
Private Sub UserForm_Initialize()
ListBox1.MultiSelect = fmMultiSelectMulti
For i = 1 To 10
ListBox1.AddItem "Blah" & i
Next
End Sub
Private Sub CommandButton1_Click()
Dim ArValues As Variant
Dim sValue As String
Dim multivalues As Boolean
If InStr(1, Range("A1").Value, ",") Then
ArValues = Split(Range("A1").Value, ",")
multivalues = True
Else
sValue = Range("A1").Value
multivalues = False
End If
If multivalues = True Then
For i = 0 To UBound(ArValues)
For j = 0 To ListBox1.ListCount - 1
If ListBox1.List(j) = ArValues(i) Then
ListBox1.Selected(j) = True
Exit For
End If
Next j
Next i
Else
For j = 0 To ListBox1.ListCount - 1
If ListBox1.List(j) = sValue Then
ListBox1.Selected(j) = True
Exit For
End If
Next j
End If
End Sub
Screenshot