Filter that has a couple of glitches and fails to work

[Pasty]

Hi there,

I have a userform which has a couple of comboboxes in it. One is for the
name - if the select the name of the dropdown it works fine but if they type
the first couple of letters for their name e.g. m and a to bring up Matthew
Wakefield the filter doesn't work.

The code for the userform is:

Private Sub cmbName_Click()
Dim rng As Range, rng1 As Range
Dim rng2 As Range, rng3 As Range
On Error GoTo ErrHandler

If cmbName.ListIndex <> -1 Then
Application.EnableEvents = False
With Worksheets("Risk by Function")
.Range("IU1").Value = cmbName.Value
Application.Calculate
Set rng = .Range(.Cells(1, 256), .Cells(1, 256).End(xlDown))
Set rng1 = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, 1)
Set rng2 = Intersect(rng1.EntireRow, .Columns(2))
rng.AutoFilter Field:=1, Criteria1:="=Show"
Set rng3 = Nothing
On Error Resume Next
Set rng3 = rng2.SpecialCells(xlVisible)
On Error GoTo ErrHandler
ComboBox1.Enabled = True
End With
If Not rng3 Is Nothing Then
RemoveDuplicates ComboBox1, rng3
Else
MsgBox "No data for " & rng.Parent.Range("IU").Value
End If
End If

ErrHandler:
Application.EnableEvents = True
If Err.Number <> 0 Then
MsgBox "Error in cmbName_Click" & vbNewLine & vbNewLine & _
Err.Number & vbNewLine & _
Err.Description
End If
End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdOkay_Click()
Me.Hide
MsgBox "Welcome to the Risk Register " & cmbName.Value & ", if you have
any problems or queries please feel free to e-mail me at
(e-mail address removed) or ring me on ext. 3303.", vbInformation
End Sub

Private Sub ComboBox1_Click()
Dim rng As Range
With Worksheets("Risk by Function")
On Error GoTo ErrHandler
Application.EnableEvents = False
With Worksheets("Risk by Function")
.Range("IT1").Value = cmbName.Value
Set rng = .Range(.Cells(1, 256), .Cells(1, 256).End(xlDown))
End With
If ComboBox1.ListIndex = -1 Then
.Range("IT1").ClearContents
Application.Calculate
rng.AutoFilter Field:=1, Criteria1:="=Show"
Else
.Range("IT1").Value = ComboBox1.Value
Application.Calculate
rng.AutoFilter Field:=1, Criteria1:="=Show"
End If
End With
ErrHandler:
Application.EnableEvents = True
If Err.Number <> 0 Then
MsgBox "Error in Combobox1_Click" & vbNewLine & vbNewLine & _
Err.Number & vbNewLine & _
Err.Description
End If

End Sub

Private Sub UserForm_Initialize()
Dim rng As Range, rng1 As Range
Dim rng2 As Range, rng3 As Range
Dim s As String, i As Long
Dim res
On Error GoTo ErrHandler
Application.EnableEvents = False
ComboBox1.Enabled = False
With Worksheets("Risk by Function")
.AutoFilterMode = False
Set rng = .Range(.Cells(1, 2), .Cells(Rows.Count, 2).End(xlUp))
Set rng3 = rng.Offset(1, 1).Resize(rng.Rows.Count - 1, 2)
ComboBox1.RowSource = ""
cmbName.RowSource = ""
For i = 1 To 12
s = Format(DateSerial(Year(Date), i, 1), "MMMM")
res = Application.Match(s, rng, 0)
If Not IsError(res) Then
ComboBox1.AddItem Format(DateSerial(Year(Date), i, 1), "MMMM")
End If
Next i
.Range("IT1:IU1").ClearContents
.Columns(256).ClearContents
End With
RemoveDuplicates Me.cmbName, rng3
Set rng1 = rng.Offset(0, 254)
Set rng2 = rng.Offset(1, 254).Resize(rng.Rows.Count - 1, 1)
rng1(1).Value = "Header1"
rng2.Formula =
"=if(and(or($B2=$IT$1,$IT$1=""""),Or($C2=$IU$1,$D2=$IU$1)),""Show"",""Hide"")"
ErrHandler:
If Err.Number <> 0 Then MsgBox Err.Number & vbNewLine & _
Err.Description
Application.EnableEvents = True
End Sub

Sub RemoveDuplicates(cb As MSForms.ComboBox, r As Range)

Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item, s As String


'
Set AllCells = r
' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
For Each Cell In AllCells
If Len(Trim(Cell)) > 0 Then
NoDupes.Add Cell.Value, CStr(Cell.Value)
End If
' Note: the 2nd argument (key) for the Add method must be a string
Next Cell

' Resume normal error handling
On Error GoTo 0
cb.ListIndex = -1
cb.Clear

If LCase(cb.Name) = "cmbname" Then

' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

' Add the sorted, non-duplicated items to a ListBox

For Each Item In NoDupes
cb.AddItem Item
Next Item
Else
For i = 1 To 12
s = Format(DateSerial(Year(Date), i, 1), "MMMM")
On Error Resume Next
NoDupes.Add s, s
If Err.Number <> 0 Then
ComboBox1.AddItem Format(DateSerial(Year(Date), i, 1), "MMMM")
End If
On Error GoTo 0
Next i
End If
End Sub

 

[Jay]

Hi Pasty -

Try running your filter code in a "Change" or "Exit" event instead of a
"Click" event.

Replace:
Private Sub cmbName_Click()
With:
Private Sub cmbName_Change()
Or with:
Private Sub cmbName_Exit(ByVal Cancel As MSForms.ReturnBoolean)

Let us know what happens. If this doesn't correct the problem, we'll follow
up.