Filter By Listbox Criteria

[mattster1010]

Morning All,

I have attached an excel spreadsheet that I'm currently working on. I want the data in 'report criteria' listbox to filter 'sheet1'. at present it's doesn't seem to be working, can anybody give me afew pointers?

Cheers,

Matt

[Bob Phillips]

[vba]

Option Explicit

Private Sub CommandButton1_Click()
Dim i As Long, Crit As Long
Dim f As Boolean

For i = 0 To Me.ListBox1.ListCount - 1

If Me.ListBox2.Selected(i) Then

f = True
Crit = Crit + 1
With Cells(1, 8)

.Value = "CASEPROD SUPPLIER NAME"
.Offset(Crit) = Me.ListBox2.List(i)
End With
End If
Next

If Not f Then

MsgBox "Select items to filter"
Exit Sub
End If

Range("Database").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("CritRange"), Unique:=False
Range("CritRange").ClearContents
End Sub

Private Sub ListBox1_Change()
Dim Lastrow As Long
Dim ListIdx As Long
Dim i As Long

ReDim ary(1 To Me.ListBox1.ListCount + 1)
Lastrow = Cells(Rows.Count, "E").End(xlUp).Row
Me.ListBox2.Clear
For i = 2 To Lastrow

If Cells(i, "E").Value2 = Me.ListBox1.Value Then

If IsError(Application.Match(Cells(i, "C").Value2, ary, 0)) Then

ListIdx = ListIdx + 1
ary(ListIdx) = Cells(i, "C").Value2
Me.ListBox2.AddItem Cells(i, "C").Value2
End If
End If
Next i

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ListBox2.AddItem ListBox1.List(ListBox1.ListIndex)
End Sub


Private Sub UserForm_Initialize()
Dim my_strings As Variant
Dim iLoop As Integer

'my_strings = Split("This is a test of ListBox for Ozgrid by Ger", " ")

'For iLoop = LBound(my_strings) To UBound(my_strings)
' ListBox1.AddItem (my_strings(iLoop))
'Next iLoop

End Sub

Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ListBox2.RemoveItem ListBox2.List(ListBox2.ListIndex)
End Sub
[/vba]

[Bob Phillips]

Here's a better, faster, version

[vba]

Option Explicit

Private Sub CommandButton1_Click()
Dim i As Long, Crit As Long
Dim f As Boolean

For i = 0 To Me.ListBox1.ListCount - 1

If Me.ListBox2.Selected(i) Then

f = True
Crit = Crit + 1
With Cells(1, 8)

.Value = "CASEPROD SUPPLIER NAME"
.Offset(Crit) = Me.ListBox2.List(i)
End With
End If
Next

If Not f Then

MsgBox "Select items to filter"
Exit Sub
End If

Range("Database").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("CritRange"), Unique:=False
Range("CritRange").ClearContents
End Sub

Private Sub ListBox1_Change()
Dim Lastrow As Long
Dim ListIdx As Long
Dim rng As Range
Dim cell As Range
Dim rngArea As Range
Static fReEntry As Boolean

If Not fReEntry Then

fReEntry = True

ReDim ary(1 To Me.ListBox1.ListCount + 1)
Lastrow = Cells(Rows.Count, "E").End(xlUp).Row
Me.ListBox2.Clear
Set rng = Range("C2:E2").Resize(Lastrow)
rng.AutoFilter Field:=3, Criteria1:=Me.ListBox1.Value
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then

For Each rngArea In rng.Areas

For Each cell In rngArea.Columns(1)

If IsError(Application.Match(cell.Value2, ary, 0)) Then

ListIdx = ListIdx + 1
ary(ListIdx) = cell.Value2
Me.ListBox2.AddItem cell.Value2
End If
Next cell
Next rngArea
End If

rng.AutoFilter

fReEntry = False
End If

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ListBox2.AddItem ListBox1.List(ListBox1.ListIndex)
End Sub


Private Sub UserForm_Initialize()
Dim my_strings As Variant
Dim iLoop As Integer

'my_strings = Split("This is a test of ListBox for Ozgrid by Ger", " ")

'For iLoop = LBound(my_strings) To UBound(my_strings)
' ListBox1.AddItem (my_strings(iLoop))
'Next iLoop

End Sub

Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ListBox2.RemoveItem ListBox2.List(ListBox2.ListIndex)
End Sub
[/vba]

[mattster1010]

Hi XLD,

Thanks for the reply. The form needs to work a bit differently. When a user selects a 'customer' from 'listbox1' that customer should appear in 'listbox2' (This currently works). The user could select up to 20 customers that appear in 'listbox2'.

When the user clicks 'Filter' I need the form to close and filter 'Sheet1' by 'CASEPROD SUPPLIER NAME' from the list of customers in 'listbox2'. That's what I'm trying to do, but its not currently working.

Any help you could give would be great.

Cheers,

Matt

[mattster1010]

Hi Everyone,

Ive turned to a new solution. See attached.

I seem to get any error on the line highligted in red:

[VBA]Private Sub Filter_Click()
Dim myLB As ListBox
Dim iCtr As Long
Dim DestCell As Range
Dim myCriteria As Range
Dim HowMany As Long
Dim ActWks As Worksheet
Dim ListWks As Worksheet
Set ActWks = Worksheets("sheet1")
Set ListWks = Worksheets("sheet2")
With ListWks
.Range("c:c").Clear
.Range("c1").Value = .Range("A1").Value
Set DestCell = .Range("c2")
End With
With ActWks
Set myLB = .ListBoxes("ListBox1")
With myLB
HowMany = 0
For iCtr = 1 To .ListCount
If .Selected(iCtr) Then
HowMany = HowMany + 1
DestCell.Value _
= "=" & Chr(34) & "=" & .List(iCtr) & Chr(34)
Set DestCell = DestCell.Offset(1, 0)
End If
Next iCtr
End With
If HowMany = 0 Then
MsgBox "Please select at least one item!"
Exit Sub
End If
Set myCriteria = ListWks.Range("c1").Resize(HowMany + 1)
.Range("a:a").AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=myCriteria
End With
End Sub[/VBA]

I can't figure out why?

Regards,

Matt

[austenr]

Are you sure about the name of that list box? Spaces count. I copied your code to a blank WB, inserted a listbox called "List Box 1" (the default name) and it got past that point.

[Bob Phillips]

[vba]

Private Sub Filter_Click()
Dim myLB As OLEObject
Dim iCtr As Long
Dim DestCell As Range
Dim myCriteria As Range
Dim HowMany As Long

Dim ActWks As Worksheet
Dim ListWks As Worksheet

Set ActWks = Worksheets("sheet1")
Set ListWks = Worksheets("sheet2")

With ListWks
.Range("c:c").Clear
.Range("c1").Value = .Range("A1").Value
Set DestCell = .Range("c2")
End With

With ActWks
Set myLB = .OLEObjects("ListBox1")
With myLB
HowMany = 0
For iCtr = 1 To .Object.ListCount
If .Object.Selected(iCtr - 1) Then
HowMany = HowMany + 1
DestCell.Value _
= "=" & Chr(34) & "=" & .Object.List(iCtr) & Chr(34)
Set DestCell = DestCell.Offset(1, 0)
End If
Next iCtr
End With

If HowMany = 0 Then
MsgBox "Please select at least one item!"
Exit Sub
End If

Set myCriteria = ListWks.Range("c1").Resize(HowMany + 1)
.Range("a:a").AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=myCriteria
End With
End Sub
[/vba]

[mattster1010]

Thanks for both of your inputs. Much appreciated.

The 'filter' button now filters records but doesn't filter the selected records in the listbox correctly. It filters the record underneath the selected record?

[Bob Phillips]

Well, you wrote the code, I just got it working for you.