I have designed an useform with listbox having multiple Options.
The listbox are populated with Locations. eg: Germany, USA etc.
If Checkbox "Germany" is true, then it should filter the results of Germany in my sheet "Result" in the column "L". If the Checkbox "GErmany and USA are checked" then I would like to have the results filtered for both the Locations in my sheet.
Surfing through Internet, I found a code like this: This works with Checkbox, how should i modify this for Listbox with multiple Option ?
Private Sub Filter()
Dim Ws As Worksheet
Dim strCriteria() As String
Dim arrIdx As Integer
Dim cBox As Control
arrIdx = 0
For Each cBox In Me.Controls
If TypeName(cBox) = "CheckBox" Then
If cBox.Value = True Then
ReDim Preserve strCriteria(0 To arrIdx)
strCriteria(arrIdx) = cBox.Caption
arrIdx = arrIdx + 1
End If
End If
Next cBox
Set Ws = ThisWorkbook.Sheets("Result")
If arrIdx = 0 Then
Ws.UsedRange.AutoFilter
Else
Ws.Range("A:R").AutoFilter Field:=12, Criteria1:=Array(strCriteria), Operator:=xlFilterValues
End If
End Sub
This works with Checkbox, how should I modify this for listbox with multiple Option like Image below
any lead would be helpful
This might be helpful for you
With ListBox1
For x = 0 To .ListCount - 1
If .Selected(x) Then
temp = temp & Chr(10) & .List(x)
End If
Next
End With
MsgBox temp & " is selected"
Try
Dim strCriteria() As String, i As Integer, arrIdx As Integer
ReDim strCriteria(0 To Me.listBoxCountries.ListCount-1)
For i = 0 To Me.listBoxCountries.ListCount - 1
If Me.listBoxCountries.Selected(i) Then
strCriteria(arrIdx) = Me.listBoxCountries.List(i)
arrIdx = arrIdx + 1
End If
Next i
If arrIdx = 0 Then
Ws.UsedRange.AutoFilter
Else
ReDim preserve strCriteria(arrIdx - 1)
Ws.Range("A:R").AutoFilter Field:=12, Criteria1:=Array(strCriteria), Operator:=xlFilterValues
End If
With the help of Fun Thomas, I edited few lines of his code and it works for my requirement.
Here is the code.
Private Sub DoFilter34()
Dim ws As Worksheet
Dim strCriteria() As String, i As Integer, arrIdx As Integer
ReDim Preserve strCriteria(0 To arrIdx)
arrIdx = 0
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) Then
ReDim Preserve strCriteria(0 To arrIdx)
strCriteria(arrIdx) = Me.ListBox1.List(i)
arrIdx = arrIdx + 1
End If
Next i
Set ws = Sheets("Result")
If arrIdx = 0 Then
ws.UsedRange.AutoFilter
Else
ws.Range("A:R").AutoFilter Field:=12, Criteria1:=Array(strCriteria), Operator:=xlFilterValues
End If
End Sub
Related
I have an user form designed with three listboxes.
The 3 listboxes are populated by the location from three different sheets.
By selecting the listbox, the user can filter the data in the sheet "Data".
if the user is selecting the "BBE Bebra" from the Listbox1. then he could find the filtered result of Bebra in the sheet.
Similary, if the user is selecting from the Listbox2, the same procedure is followed and if the user is selecting from listbox3, the same procedure is followed.
The user can also, select all the three checkbox and looks for the filtered result in the sheet.
I have a issues with the working code.
If I am selecting the checkboxes and click "Filter" then I always see the filtered result. The next time I click on the Filter Button I would like to see the whole data sheet with filters clear and checkboxes cleared.
Can someone tell how I can do it ?
Below is the code, I am using in the filter button
Sub DoFilter()
Dim strCriteria() As String
Dim strCriteria2() As String
Dim strcriteria3() As String
Dim arrIdx As Integer
Dim arrIdx2 As Integer
Dim arrIdx3 As Integer
Dim xRow As Integer
Dim arrCounter As Integer
Dim lo As ListObject
arrIdx = 0
arrIdx2 = 0
arrIdx3 = 0
For xRow = 2 To Last(1, List.Cells)
If List.Cells(xRow, 2) = True Then
ReDim Preserve strCriteria(0 To arrIdx)
strCriteria(arrIdx) = List.Cells(xRow, 3)
arrIdx = arrIdx + 1
End If
Next xRow
For xRow = 2 To Last(1, List.Cells)
If List_Man.Cells(xRow, 2) = True Then
ReDim Preserve strCriteria2(0 To arrIdx2)
strCriteria2(arrIdx2) = List_Man.Cells(xRow, 3)
arrIdx2 = arrIdx2 + 1
End If
Next xRow
For xRow = 2 To Last(1, List.Cells)
If List_S.Cells(xRow, 2) = True Then
ReDim Preserve strcriteria3(0 To arrIdx3)
strcriteria3(arrIdx3) = List_S.Cells(xRow, 3)
arrIdx3 = arrIdx3 + 1
End If
Next xRow
Set Ws = ThisWorkbook.Sheets("Data")
Set lo = Ws.ListObjects("Table7")
If arrIdx = 0 And arrIdx2 = 0 And arrIdx3 = 0 Then
'Ws.UsedRange.AutoFilter
Else
With Ws
With lo
'.AutoFilterMode = True
' .UsedRange.AutoFilter
If arrIdx <> 0 Then
.Range.AutoFilter field:=13, Criteria1:=Array(strCriteria), Operator:=xlFilterValues
End If
If arrIdx2 <> 0 Then
.Range.AutoFilter field:=14, Criteria1:=Array(strCriteria2), Operator:=xlFilterValues
End If
If arrIdx3 <> 0 Then
.Range.AutoFilter field:=15, Criteria1:=Array(strcriteria3), Operator:=xlFilterValues
End If
If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then
MsgBox " Your filter has no result"
End If
End With
End With
Dim i As Long
On Error Resume Next
With ThisWorkbook.Worksheets("Dev").PivotTables("PivotTable1").PivotFields("Lo.")
.ClearAllFilters
For i = 1 To .PivotItems.Count
.PivotItems(i).Visible = False
Next
For arrCounter = LBound(strCriteria) To UBound(strCriteria)
.PivotItems(strCriteria(arrCounter)).Visible = True
Next arrCounter
End With
End If
End Sub
I call the function do filter in my button "Filter".
with the button "exit" I always have the
following code
Private Sub CBExit_Click()
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Sheets("Dev").Select
Sheets("Dev").PivotTables("PivotTable1").PivotFields("Development Loc.").ClearAllFilters
Unload Me
End Sub
You will need to keep track of your current state using some sort of flag. I would do something like the following:
Private Sub Filter_Click()
If Filter.Caption = "Filter" Then
DoFilter
Filter.Caption = "Unfilter"
Else
'do logic to clear
Filter.Caption = "Filter"
End If
End Sub
This has the added benefit of telling the user what the next click of the button will do.
I'm trying to add a list of names from another worksheet that has duplicates. On the listbox, I want to have unique names, instead of duplicates. The following code is not sorting them for duplicates, it errors out. Any help is appreciated.
Dim intCount As Integer
Dim rngData As Range
Dim strID As String
Dim rngCell As Range
dim ctrlListNames as MSForms.ListBox
Set rngData = Application.ThisWorkbook.Worksheets("Names").Range("A").CurrentRegion
'declare header of strID and sort it
strID = "Salesperson"
rngData.Sort key1:=strID, Header:=xlYes
'Loop to add the salesperson name and to make sure no duplicates are added
For Each rngCell In rngData.Columns(2).Cells
If rngCell.Value <> strID Then
ctrlListNames.AddItem rngCell.Value
strID = rngCell.Value
End If
Next rngCell
Way 1
Use this to remove the duplicates
Sub Sample()
RemovelstDuplicates ctrlListNames
End Sub
Public Sub RemovelstDuplicates(lst As msforms.ListBox)
Dim i As Long, j As Long
With lst
For i = 0 To .ListCount - 1
For j = .ListCount - 1 To (i + 1) Step -1
If .List(j) = .List(i) Then
.RemoveItem j
End If
Next
Next
End With
End Sub
Way 2
Create a unique collection and then add it to the listbox
Dim Col As New Collection, itm As Variant
For Each rngCell In rngData.Columns(2).Cells
On Error Resume Next
Col.Add rngCell.Value, CStr(rngCell.Value)
On Error GoTo 0
Next rngCell
For Each itm In Col
ctrlListNames.AddItem itm
Next itm
Private Sub Workbook_Open()
Dim ctrlListNames As MSForms.ListBox
Dim i As Long
Dim j As Long
ctrlListNames.List = Application.ThisWorkbook.Worksheets("Names").Range("Salesperson").Value
With ctrlListNames
For i = 0 To .ListCount - 1
For j = .ListCount To (i + 1) Step -1
If .List(j) = .List(i) Then
.RemoveItem j
End If
Next
Next
End With
End Sub
And it says invalid property array index.
It says invalid property array index because the list gets shortened after the removal of entries. if we use FOR, the end value is static, therefore, we need to use DO while loop. Use the following code to remove duplicates.
Count = ListBox1.ListCount - 1
i = 0
j = 0
Do While i <= Count
j = i + 1
Do While j <= Count
If ListBox1.List(i) = ListBox1.List(j) Then
ListBox1.RemoveItem (j)
Count = ListBox1.ListCount - 1 'Need to update list count after each removal.
End If
j = j + 1
Loop
i = i + 1
Loop
First off, just starting trying to learn Excel and VBA yesterday....so bear in mind.
Private Sub CommandButton2_Click()
For a = 1 To myLastRow
Select Case ActiveWorkbook.Sheets("Sheet2").Cells(a, 2).Value
Case Is = myOrderNumber
ActiveWorkbook.Sheets("Sheet2").Cells(a, 2).Active
Case False: MsgBox "False"
End Select
Next a
End Sub
I want to know which cell or the row of the cell that matches my variable. This does not do what I want.......
Thanks guys
I appreciate you are learning code. But beyond getting the range syntax correct two better methods (efficiency wise) are shown below
Array
recut
Private Sub CommandButton2_Click()
Dim myLastRow As Long
Dim myOrderNumber As Long
Dim lngCnt As Long
Dim ws As Worksheet
Dim X
myOrderNumber = 2
Set ws = ActiveWorkbook.Sheets("Sheet2")
X = ws.Range(ws.[b1], ws.[b10])
For lngCnt = 1 To UBound(X)
If X(lngCnt, 1) = myOrderNumber Then MsgBox "True " & lngCnt
Next
End Sub
Evaluate
From Is it possible to fill an array with row numbers which match a certain criteria without looping?
myOrderNumber = 2
MsgBox Join(Filter(Application.Transpose(Application.Evaluate("=IF(B1:B10=" & myOrderNumber & ",ROW(B1:B10),""x"")")), "x", False), ",")
Try this
Private Sub CommandButton2_Click()
Dim myLastRow As Long, a As Long, myOrderNumber As Long
myLastRow = 10
For a = 1 To myLastRow
With ActiveWorkbook.Sheets("Sheet2")
If .Cells(a, 2).Value = myOrderNumber Then
MsgBox "True " & .Cells(a, 2).Row
Else
Msgbox "False"
End If
End With
Next a
End Sub
For a = 1 To myLastRow
With ActiveWorkbook.Sheets("Sheet2")
If .Cells(a, 2).Value = myOrderNumber Then
myRow = .Cells(a, 2).Row
MsgBox "True " & myRow
Else
'MsgBox "False "
End If
End With
Next a
It's me again!
I am trying to input data into a database with a userform by looping through each control and pasting it into a cell via an offset with a counter. I am getting an error on the line which actually inputs the data to the cell and cannot figure out how to do this via a loop. It would be easy to do it field by field but I do not want to write that many lines of code.
Here is my most recent attempt:
Option Explicit
Sub cbSubmit_Click()
' Set worksheet
Dim dbFood As Worksheet
Set dbFood = Sheets("dbFood")
'Set last row and column
Dim lRow As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim lCol As Long
lCol = Cells(1, Columns.Count).End(xlLeft).Row
'Define idCell as Range type
Dim idCell As Range
' If no records exit, add first record
If Cells(lRow, 1).Value = "ID" Then
Set idCell = dbFood.Range("A2")
idCell.Value = 1
' Add Data
Dim ufControl As Control
Dim Counter As Long
Counter = 1
For Each ufControl In Me.Controls
If TypeOf ufControl Is MSForms.ComboBox Or MSForms.TextBox Then
idCell.Offset(0, Counter).Value = ufField.Value
Counter = Counter + 1
End If
Next ufControl
MsgBox "Added to database!"
' Else add next record
ElseIf Cells(lRow, 1).Value >= 0.1 Then
Dim lastID As Long
lastID = Cells(lRow, 1).Value
Set idCell = dbFood.Cells(lRow + 1, 1)
idCell.Value = lastID + 1
' Add Data
' If none of the above display ERROR and exit sub
Else: MsgBox ("ERROR - Cannot Create Record")
Exit Sub
End If
End Sub
If anyone could help me figure out how to solve this one then great!
I managed to solve this by using the method Kathara suggested to me but edited it to avoid the 438 error. Below is the small adjustment I made to make it work:
For Each ufControl In Me.Controls
If TypeOf ufControl Is MSForms.TextBox Then
idCell.Offset(0, Counter).Value = ufControl.Text
Counter = Counter + 1
ElseIf TypeOf ufControl Is MSForms.ComboBox Then
idCell.Offset(0, Counter).Value = ufControl.Text
Counter = Counter + 1
End If
Next ufControl
Many thanks for your help :)
I saw some things that I have adapted down below. May I ask you to test that bit of code?
Option Explicit
Sub cbSubmit_Click()
Dim dbFood As Worksheet
Set dbFood = ActiveWorkbook.Sheets("dbFood")
Dim lRow As Long
lRow = dbFood.Cells(dbFood.Rows.Count, 1).End(xlUp).Row
Dim lCol As Long
lCol = dbFood.Cells(1, dbFood.Columns.Count).End(xlLeft).Row
Dim idCell As Range
If dbFood.Cells(lRow, 1).Value = "ID" Then
Set idCell = dbFood.Range("A2")
idCell.Value = 1
Dim ufControl As Control
Dim Counter As Long
Counter = 1
For Each ufControl In Me.Controls
If TypeOf ufControl Is MSForms.TextBox Then
idCell.Offset(0, Counter).Value = ufControl.Result
Counter = Counter + 1
ElseIF TypeOf ufControl Is MSForms.ComboBox
idCell.Offset(0, Counter).Value = ufControl.SeletedItem.Value
End If
Next ufControl
MsgBox "Added to database!"
ElseIf dbFood.Cells(lRow, 1).Value >= 0.1 Then
Dim lastID As Long
lastID = dbFood.Cells(lRow, 1).Value
Set idCell = dbFood.Cells(lRow + 1, 1)
idCell.Value = lastID + 1
Else
MsgBox ("ERROR - Cannot Create Record")
Exit Sub
End If
End Sub
As you can see I have divided the types of the ufcontrol as I am not sure that with a combobox you can directly say .Value so you'll have to add .SelectedItem. You can at least try it once :)
I have been thinking how to sort the values in a combobox.
I add items to the ComboBox when I initilize the form because the number of values are constantly increasing on a sheet.
I use the next code to add the items:
With ComboBox1
lastcell = ThisWorkbook.Sheets("1").Range("F1000000").End(xlUp).Row + 1
For i = 2 To lastcell
.AddItem ThisWorkbook.Sheets("1").Cells(i, 6)
Next i
End With
I thought to copy the values that I am going to add on the ComoBox to another sheet and there sort them in the new sheet, it works fine but it doesn't seem to be a smart option, meaning that I create another sheet and then copy the values and sort them instead of sorting them directly.
My question is, anyone knows how to do it directly from the original sheet? I dont know anything of API so, please, only VBA code. I alredy check on MSDN but I can't figure out how to make it work.
Thanks and if more info is needed, please, let me know it.
PS: I cant sort them directly from the original sheet because this Sheet has to be with a static order
You can read the values from the sheet into an array, sort this with code and then add the items.
This code will do this, using a Quicksort:
Private Sub UserForm_Initialize()
Dim varRange() As Variant
Dim lngLastRow As Long
Dim i As Long
lngLastRow = Range("F:F").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
varRange = Range("F:F").Resize(lngLastRow).Cells
subQuickSort varRange
Me.ComboBox1.List = varRange
End Sub
Public Sub subQuickSort(var1 As Variant, _
Optional ByVal lngLowStart As Long = -1, _
Optional ByVal lngHighStart As Long = -1)
Dim varPivot As Variant
Dim lngLow As Long
Dim lngHigh As Long
lngLowStart = IIf(lngLowStart = -1, LBound(var1), lngLowStart)
lngHighStart = IIf(lngHighStart = -1, UBound(var1), lngHighStart)
lngLow = lngLowStart
lngHigh = lngHighStart
varPivot = var1((lngLowStart + lngHighStart) \ 2, 1)
While (lngLow <= lngHigh)
While (var1(lngLow, 1) < varPivot And lngLow < lngHighStart)
lngLow = lngLow + 1
Wend
While (varPivot < var1(lngHigh, 1) And lngHigh > lngLowStart)
lngHigh = lngHigh - 1
Wend
If (lngLow <= lngHigh) Then
subSwap var1, lngLow, lngHigh
lngLow = lngLow + 1
lngHigh = lngHigh - 1
End If
Wend
If (lngLowStart < lngHigh) Then
subQuickSort var1, lngLowStart, lngHigh
End If
If (lngLow < lngHighStart) Then
subQuickSort var1, lngLow, lngHighStart
End If
End Sub
Private Sub subSwap(var As Variant, lngItem1 As Long, lngItem2 As Long)
Dim varTemp As Variant
varTemp = var(lngItem1, 1)
var(lngItem1, 1) = var(lngItem2, 1)
var(lngItem2, 1) = varTemp
End Sub
It depends on circumstances, type and structure of data. But i prefer to do it this way:
You could alternatively use an array and a bubble sort algo :)
modify the code a little bit to suit your case
Option Explicit
Sub WITH_COMBOBOX()
Dim i As Long
Dim arr() As String
Dim lastCell As Long
lastCell = 500
ReDim arr(lastCell)
Call FillAndSortArray(arr)
For i = 2 To lastCell
.AddItem arr(i - 2)
Next i
End Sub
Sub FillAndSortArray(ByRef myArray() As String)
Dim i As Long
For i = LBound(myArray) To UBound(myArray)
myArray(i) = CStr(ThisWorkbook.Sheets(1).Range("F" & i + 2).Value)
Next i
Call BubbleSort(myArray)
End Sub
Sub BubbleSort(ByRef myArray() As String)
Dim i As Long, j As Long
Dim Temp As String
For i = LBound(myArray) To UBound(myArray) - 1
For j = i + 1 To UBound(myArray) - 1
If myArray(i) > myArray(j) Then
Temp = myArray(j)
myArray(j) = myArray(i)
myArray(i) = Temp
End If
Next j
Next i
End Sub
Try below code :
Sub GetAction()
Dim rng As Range, lastcell As Long
lastcell = Range("F1000").End(xlUp).Row + 1
Set rng = Range("F1:F" & lastcell) ' assuming to start from F1
If Not rng Is Nothing Then
rng.Sort Range("F1")
ComboBox1.ListFillRange = rng.Address
End If
End Sub
for sorting 123 for number
For Each cell In ThisWorkbook.Sheets("sheet1").Range("list1")
Me.ComboBox1.AddItem cell
Next cell
With Me.ComboBox1
For x = LBound(.list) To UBound(.list)
For y = x To UBound(.list)
If .list(y, 0) + 0 < .list(x, 0) + 0 Then
blah = .list(y, 0)
.list(y, 0) = .list(x, 0)
.list(x, 0) = blah
End If
Next y
Next x
End With
for sorting text abcd
For Each cell In ThisWorkbook.Sheets("sheet1").Range("list1")
Me.ComboBox1.AddItem cell
Next cell
With Me.ComboBox1
For x = LBound(.list) To UBound(.list)
For y = x To UBound(.list)
If .list(y, 0) < .list(x, 0) Then
blah = .list(y, 0)
.list(y, 0) = .list(x, 0)
.list(x, 0) = blah
End If
Next y
Next x
End With