Dim WithEvents bSB As MSForms.SpinButton
Dim WithEvents bTBFind As MSForms.TextBox
Public arr
Const EnterMessage = "<-- Enter search criteria"
Private Sub bSB_Change()
On Local Error GoTo outtahere
UserForm1.Controls("lblCount").Caption = EnterMessage
For i = 1 To 33
With Me.Controls("TB" & Right("000" & i, 3)) ' display selected data
.BackColor = bTBFind.BackColor ' and color tb(s) that meet criteria
.Value = Cells(arr(bSB.Value - 1), i) ' value
If InStr(.Text, bTBFind.Text) > 0 Then .BackColor = &HC0FFC0 ' color
End With
Next i
' change x of x label
UserForm1.Controls("lblCount").Caption = bSB.Value & " of " & UBound(arr) + 1
Exit Sub
outtahere: ' error (not found)clear all tbs
For i = 1 To 33
With Me.Controls("TB" & Right("000" & i, 3))
.BackColor = bTBFind.BackColor
.Value = ""
End With
Next
End Sub
Private Sub bTBFind_Change()
arr = DisplayRecords(bTBFind.Text) ' TB has changed, find data
bSB.Max = UBound(arr) + 1 ' arr has the list of rows to display
bSB.Value = 1 ' set spin value to first record
bSB_Change ' force SpinButton change event
End Sub
Private Sub UserForm_Initialize() ' Set up form from blank...
Me.Width = 475
Me.Height = 275
ct = 1
Set bTBFind = Me.Controls.Add("Forms.TextBox.1", "TBFind")
With bTBFind
.Left = 10
.Top = 10
.Width = 90
.Height = 20
End With
For j = 1 To 10
For k = 1 To 5
With Me.Controls.Add("Forms.TextBox.1", "TB" & Right("000" & ct, 3))
.Left = 10 + (k - 1) * 90
.Top = 40 + (j - 1) * 30
.Width = 90
.Height = 20
.Text = .Name
End With
ct = ct + 1
If ct > 33 Then Exit For
Next
If ct > 33 Then Exit For
Next
Me.Controls.Add "Forms.Label.1", "lblCount"
With UserForm1.Controls("lblCount")
.Left = bTBFind.Left + bTBFind.Width + 10
.Top = 15
.Width = 200
.Height = 15
End With
Set bSB = Me.Controls.Add("Forms.SpinButton.1", "SB1")
With bSB
lr = Cells(Rows.Count, 1).End(xlUp).Row
.Max = Cells(Rows.Count, 1).End(xlUp).Row
.Min = 1
.Value = 1
.Top = 10
.Width = 60
.Height = 20
.Left = 0.5 * (Me.Width - .Width)
End With
End Sub
Function DisplayRecords(Optional sVal = "") As Variant
Dim i
If sVal = "" Then
ReDim arr(ActiveSheet.UsedRange.Rows.Count - 1)
For i = 1 To ActiveSheet.UsedRange.Rows.Count - 1
arr(i) = i
Next
DisplayRecords = arr
Exit Function
End If
Dim d: Set d = CreateObject("Scripting.Dictionary")
Dim rng As Range: Set rng = ActiveSheet.UsedRange
Dim firstaddress, fnd
d.removeall
With ActiveSheet.Cells
Set fnd = .Find(What:=CStr(sVal), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not fnd Is Nothing Then
firstaddress = fnd.Address
Do
If d.exists(fnd.Row) = False Then
d.Add fnd.Row, fnd.Row
End If
Set fnd = .FindNext(fnd)
Loop While Not fnd Is Nothing And fnd.Address <> firstaddress
End If
End With
DisplayRecords = d.items
End Function