How to display Values from a multiselect listbox - vba

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

Related

Excel VBA Userform CheckBox check mark does not appear

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.

Array insertion of Duplicated and not duplicated data to different column in VBA

Good day! in my worksheet i have (1) textbox as TextBox1 and 1 button for submit button. I have here sample code that gives splitted text as an output. I just want that if there's duplicated word in textbox1 and the user enters the submit button it will saves to worksheet(DatabaseStorage) and categorize the output from No Duplicated Word and With duplicated Word. Because this two different fields will be needed for some function of the system.
Private Sub CommandButton1_Click()
Call SplitText
End Sub
Sub SplitText()
Dim WArray As Variant
Dim TextString As String
TextString = TextBox1
WArray = Split(TextBox1, " ")
If (TextString = "") Then
MsgBox ("Error: Pls Enter your data")
Else
With Sheets("DatabaseStorage")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(WArray) + IIf(LBound(WArray) = 0, 1, 0)) = Application.Transpose(WArray)
End With
MsgBox ("Successfully inserted")
End If
End Sub
This should accomplish what you need. I loop through the array to check if the given value exists in the "No Duplicates" column. If not, don't print it there.
Any time I encounter a situation where I need to check a single value against a list (ex. check for duplicates, GT/LT, etc.), I consider looping.
Sub SplitText()
Dim WArray As Variant
Dim TextString As String
Dim col_no_dup As Long
Dim col_dup As Long
Dim counter As Integer
Dim sht_database As Worksheet
With ThisWorkbook
Set sht_database = .Sheets("DatabaseStorage")
TextString = LCase(.Sheets("Sheet1").Shapes("Textbox1").DrawingObject.Text)
End With
WArray = Split(TextString, " ") 'load array
If (TextString = "") Then
MsgBox ("Error: Pls Enter your data")
End
Else: End If
'set column locations for duplicates/no duplicates
col_no_dup = 1
col_dup = 2
With sht_database
.Range("A2:B10000").ClearContents 'clear existing data. Change this as needed
'Print whole array into duplicates column
.Cells(Cells.Rows.Count, col_dup).End(xlUp).Offset(1, 0).Resize(UBound(WArray) + IIf(LBound(WArray) = 0, 1, 0)) = Application.Transpose(WArray)
'Loop through array
For i = LBound(WArray) To UBound(WArray)
counter = 0
lrow_no_dup = .Cells(Cells.Rows.Count, col_no_dup).End(xlUp).Row
For n = 1 To lrow_no_dup 'loop through and check each existing value in the no dup column
If .Cells(n, col_no_dup).Value = WArray(i) Then
counter = counter + 1 'account for each occurence
Else: End If
Next n
If counter = 0 Then 'counter = 0 implies the value doesn't exist in the "No Duplicates" column
.Cells(lrow_no_dup + 1, col_no_dup).Value = WArray(i)
Else: End If
Next i
End With
MsgBox ("Successfully inserted")
End Sub

VBA: Array cell reference Mismatch error

UPDATED 3/30
So I adjusted the code and it runs error free now but the issue is that it does not pull the correct data. X basically starts with cell(X,1) and goes on from there. How do I link X to the selected listbox options in the array?
OLD Message:
I have a userform that allows for multi-select of Countries and also Questions about that specific country. These are stored in arrCountries & arrQuestion respectively. This then feeds to my main sub which calls for a Web Query Import from the CIA World Factbook site. I keep however getting a mismatch error that I cannot seem to sort out how to get around:
If I had to guess it is because when I am filling the array from the listbox's it is just adding a string and not the cell reference that the string is located at (or I am completely wrong).
My worksheet has only 1 sheet when started called Countries and the Column A is the URL and Column B is the Country name. I have Defined Public arrCountry(), Public arrQuestion(), and Public X as variant.
Code here:
Userform Code when click okay:
'Handles when the user clicks okay
Private Sub cbOkay_Click()
'Me.Hide
'Capture ticker selection(s) from list box.
Dim cI As Long
Dim cX As Long
Dim qI As Long
Dim qX As Long
'Stores the Countries selected into an array
If lbCountries.ListIndex <> -1 Then
For cI = 0 To lbCountries.ListCount - 1
If lbCountries.Selected(cI) Then
ReDim Preserve arrCountry(cX)
arrCountry(cX) = lbCountries.List(cI)
cX = cX + 1
End If
Next cI
End If
If cX = 0 Then MsgBox "Please select at least one country to analyse."
'MsgBox Join(arrCountry, vbCrLf)
'Stores the Questions selected into an array
If lbQuestions.ListIndex <> -1 Then
For qI = 0 To lbQuestions.ListCount - 1
If lbQuestions.Selected(qI) Then
ReDim Preserve arrQuestion(qX)
arrQuestion(qX) = lbQuestions.List(qI)
qX = qX + 1
End If
Next qI
End If
If qX = 0 Then MsgBox "Please select at least one question to analyse."
'MsgBox Join(arrQuestion, vbCrLf)
'Unload the form
Unload Me
cancel = False
End Sub
The message boxes return the correctly selected Listbox items so I know they are being stored correctly.
The WebQuery Code I am getting the error on:
UPDATED CODE:
So I added a loop counter:
Sub webQueryimport(arrCountry())
Dim mystr As String
Dim X As Integer
Dim selected As Variant
For Each selected In arrCountry
X = X + 1
Worksheets("Countries").Select
Worksheets("Countries").Activate
mystr = Cells(X, 1)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = selected
With ActiveSheet.QueryTables.Add(Connection:=mystr, Destination:=Range("$A$1"))
.WebSelectionType = xlEntirePage 'this tells VBA what to select and import
.WebFormatting = xlWebFormattingNone 'this turns off web formatting, otherwise text is various sizes
.Refresh BackgroundQuery:=False 'if commented out, doesn't add any data
End With
Next selected
End Sub
Again, now that loop works and will import but it always starts with the A1 no matter what is selected in the listbox and in arrCountries
Any thoughts/assistance would be great!
Got it:
Sub webQueryimport(arrCountry())
Dim mystr As String
Dim X As Integer
Dim rng As Range
Dim selected As Variant
Set rng = Range("B1")
For Each selected In arrCountry()
For X = 1 To 5 'rng.Offset(0, 0).End(xlDown).Rows.count
Worksheets("Countries").Select
Worksheets("Countries").Activate
If Cells(X, 2).Value = selected Then
mystr = Cells(X, 1).Value
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = selected
With ActiveSheet.QueryTables.Add(Connection:=mystr, Destination:=Range("$A$1"))
.WebSelectionType = xlEntirePage 'this tells VBA what to select and import
.WebFormatting = xlWebFormattingNone 'this turns off web formatting, otherwise text is various sizes
.Refresh BackgroundQuery:=False 'if commented out, doesn't add any data
End With
End If
Next X
Next selected
End Sub
I needed to add in a counter and the IF statement to check to see if the value in the array matched the cell value in the sheet and then return the appropriate cell for the import.

Multiple checkboxes in dropdown list for multiple cells

I have a column K that is headed with "Downloads". I want to be able to click a cell in column K, then a listbox with checkboxes appears and I select from a list of 7 (which is stored in another sheet) the names of the files that have been downloaded by that user. These are then added to the cell, separated by commas.
The issue I'm having is that each cell in column K needs to be different, so for example, if my list of downloads is "Item A, Item B, Item C" etc. and then in K3 I check Item A, then it should display just Item A. However, then if I click K29 and select Item A, B and C, then it should display "Item A, Item B, Item C" in that cell.
Here's an example of something I was testing which didn't work as it filled EVERY cell in column K with what I checked. Also, the dropdown was always visible and I only want it visible when a cell is clicked:
Private Sub ListBox1_Change()
Dim lngCurrentItem As Long
Dim strCurrentItem As String
Dim strAllSelectedItems As String
Dim rngOutput As Range
Set rngOutput = [K1:K999]
strAllSelectedItems = ""
For i = 0 To ListBox1.ListCount - 1
strCurrentItem = ListBox1.List(i)
If ListBox1.Selected(i) Then
If strAllSelectedItems = "" Then
strAllSelectedItems = strCurrentItem
Else
strAllSelectedItems = strAllSelectedItems & " - " & strCurrentItem
End If
End If
Next i
If strAllSelectedItems = "" Then
rngOutput = "No Items Selected"
ElseIf InStr(1, strAllSelectedItems, " - ", vbTextCompare) > 0 Then
rngOutput = strAllSelectedItems & " Are Selected"
Else
rngOutput = strAllSelectedItems & " Is Selected"
End If
End Sub
I think I'd use a Userform if I were doing this.
You can insert one in your editor and make it look like this:
I've added a Label and changed its properties as follows:
Name = lblPrompt
Autosize = true
Wordwrap = false
I've added a Listbox and changed its properties as follows:
Name = lboxItems
MultiSelect = 1 - fmMultiSelectMulti
ListStyle = 1 - fmListStyleOption
List item = Sheet2!A1:A7 ~> use the range of your own items.
I've added 2 CommandButtons and named them btnOk and btnCanx (and changed their captions to 'OK' and 'Cancel'.
Then in the code for the Userform, I've used:
Option Explicit
Private mCell As Range
Public Sub PopUp(user As String, cell As Range)
Dim i As Integer
Set mCell = cell
lblPrompt = "Downloads by " & user
For i = 0 To lboxItems.ListCount - 1
lboxItems.Selected(i) = False
Next
Me.Show
End Sub
Private Sub btnCanx_Click()
Me.Hide
End Sub
Private Sub btnOk_Click()
Dim i As Integer
Dim itemText As String
For i = 0 To lboxItems.ListCount - 1
If lboxItems.Selected(i) Then
If Len(itemText) > 0 Then
itemText = itemText & ", "
End If
itemText = itemText & lboxItems.List(i)
End If
Next
mCell.Value = itemText
Me.Hide
End Sub
And, finally, on the Worksheet code behind. I've put:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cell As Range
Dim user As String
For Each cell In Target.Cells
If Not Intersect(cell, Columns("K")) Is Nothing Then
user = CStr(cell.Offset(, -10).Value2)
UserForm1.PopUp user, cell
End If
Next
End Sub

Multiple ListBox selection avoiding duplicates VBA

I am building a Userform which contains two ListBoxes such that the user can select options from ListBox1 and add them to ListBox2 or alternatively remove options from ListBox2
What I am struggling with is how can I prevent the duplicates from being added to the ListBox2? Essentially, I want to build in a function (?) which checks if an option is already included in ListBox2
Private Sub CommandButton3_Click()
'### Adds Items from ListBox1 to ListBox2
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then ListBox2.AddItem ListBox1.List(i)
Next i
ListBox1.Selected
End Sub
Private Sub CommandButton4_Click()
'### Removes Items from ListBox2
Dim counter As Integer
counter = 0
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i - counter) Then
ListBox2.RemoveItem (i - counter)
counter = counter + 1
End If
Next i
End Sub
The code below worked as a solution to the problem:
Private Sub CommandButton3_Click()
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
valCheck (ListBox1.List(i))
End If
Next i
End Sub
Private Function valCheck(str As String)
'### Adds Items from ListBox1 to ListBox2
Dim valExists As Boolean
valExists = False
For i = 0 To ListBox2.ListCount - 1
If ListBox2.List(i) = str Then
valExists = True
End If
Next i
If valExists Then
MsgBox ("already exists")
Else
ListBox2.AddItem str
End If
End Function
Private Sub CommandButton4_Click()
'### Removes Items from ListBox2
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) = True Then ListBox2.RemoveItem (i)
Next i
End Sub