I have made a userform which automatically adds Textboxes & Labels depending on how many rows/Columns there are in the Sheet.
Now I have a problem, for example if I had "Steve" with number like 4, it would not show the exact number in the cell Instead it will show the Row number.
Excel Data Sheet Screenshot
So what I want is to fix the Number : Label and also make the TextBox for example now if i type 1 it will show the data for the Row number 1 i want to make it work with "Steve" writing a "4" instead of a "2" Which is the row number.
Here is the Userform code:
Private Sub CommandButton1_Click()
'Exit Form
Unload Me
End Sub
Private Sub CommandButton2_Click()
'Edit
k = ScrollBar1.Value
lcol = Sheet1.Range("DX2").End(xlToLeft).Column
For j = 1 To lcol
Sheet1.Cells(k + 1, j) = Me.Controls("textbox" & j)
Next j
End Sub
Private Sub CommandButton3_Click()
'Delete
k = ScrollBar1.Value
Sheet1.Cells(k + 1, 1).EntireRow.Delete
End Sub
Private Sub ScrollBar1_Change()
Dim Rng As Range
lcol = Sheet1.Range("DX2").End(xlToLeft).Column
k = ScrollBar1.Value
k2 = TextBox1000.Value
label1000.Caption = "Number : " & k
If k <> 0 And k2 <> 0 Then
TextBox1000.Value = k
For j = 1 To lcol
Me.Controls("textbox" & j).Text = Sheet1.Cells(k, j).Offset(1, 0).Value
Next j
End If
End Sub
Private Sub TextBox1000_Change()
lcol = Sheet1.Range("DX2").End(xlToLeft).Column
k = ScrollBar1.Value
k2 = TextBox1000.Value
label1000.Caption = "Number : " & k2
If k2 <> "" Then
ScrollBar1.Value = k2
For j = 1 To lcol
Me.Controls("textbox" & j).Text = Sheet1.Cells(k2, j).Offset(1, 0).Value
Next j
End If
End Sub
Private Sub UserForm_Initialize()
Dim myLabel As Control
Dim txtbox As Control
k = ScrollBar1.Value
label1000.Caption = "Number : " & k
lcol = Sheet1.Range("DX2").End(xlToLeft).Column
For i = 1 To lcol
Set myLabel = Frame1.Controls.Add("Forms.label.1", "label" & i, True)
myLabel.Left = 250
myLabel.Top = 12 + (i * 20)
myLabel.Width = 150
myLabel.Height = 15
Set txtbox = Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i, True)
txtbox.Left = 50
txtbox.Top = 10 + (i * 20)
txtbox.Width = 180
txtbox.Height = 60
Next i
For j = 1 To lcol
With Frame1.Controls("label" & j)'Formating Labels
.Caption = Sheet1.Cells(1, j).Value
.TextAlign = fmTextAlignCenter
.Font.Bold = True
.Font.Size = 11
.FontName = "Times New Roman"
.ForeColor = vbRed
End With
With Frame1.Controls("TextBox" & j) 'Formating TextBoxes
.Text = Sheet1.Cells(1, j).Offset(1, 0).Value
.TextAlign = fmTextAlignRight
.Font.Bold = True
.Font.Size = 11
.FontName = "Times New Roman"
End With
With Frame1.Controls("TextBox1")'Make textbox1 not editable
.Enabled = False
End With
With Frame1.Controls("TextBox3")'Make textbox3 not editable
.Enabled = False
End With
Next j
End Sub
I'd say
Label1000.Caption = "Number : " & Sheet1.Cells(k + 1, 1).Value
Related
I have written the following code for one of my worksheets.
Sub Hide_Projects()
Application.ScreenUpdating = False
i = 6
For i = 6 To 350
Cells(9, i).Select
If Selection.Value = "Project" Then
ActiveCell.EntireColumn.Hidden = True
Else
ActiveCell.EntireColumn.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub
It works fine, does exactly what I need it to every time without crashing or lagging. However, when I use a similar code on a different worksheet, only this time applied to rows rather than columns, it either crashes my Excel or takes about 2 minutes to run, even though the code is identical. This is the second code:
Sub Hide_Projects_5yr()
Application.ScreenUpdating = False
i = 6
For i = 6 To 350
Cells(i, 7).Select
If Selection.Value = "Project" Then
ActiveCell.EntireRow.Hidden = True
Else
ActiveCell.EntireRow.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub
Does anyone have any idea why this is the case?
Thank you!
Obviously columns are times faster to hide than rows. I have tried this:
Option Explicit
Public Sub TestingSpeed()
Dim lngCount As Long
Dim dtTime As Date
Columns.Hidden = False
rows.Hidden = False
dtTime = Now
For lngCount = 1 To 300
rows(lngCount).Hidden = True
Next lngCount
Debug.Print "Rows: -> "; DateDiff("s", dtTime, Now())
dtTime = Now
For lngCount = 1 To 300
Columns(lngCount).Hidden = True
Next lngCount
Debug.Print "Cols: -> "; DateDiff("s", dtTime, Now())
End Sub
The result is the following (in seconds):
Rows: -> 9
Cols: -> 2
And the difference grows somehow exponentially.
With 1.000 samples it is like this:
Rows: -> 11
Cols: -> 1
With 10.000 like this:
Rows: -> 19
Cols: -> 10
It is very likely that your active sheet is not the one you intend to work on. It is always best to avoid Select and ActiveCell, because you are dependent on the cursor location. Not sure you need the false case, unless you use the same sheet over and over again and it may be hidden.
Sub Hide_Projects_5yr()
Application.ScreenUpdating = False
Dim ws as Worksheet
Set ws = Sheets("YourSheetName")
For i = 6 To 350
If ws.Cells(i, 7).Value = "Project" Then
ws.Cells(i, 7).EntireRow.Hidden = True
Else
ws.Cells(i, 7).EntireRow.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub
Could you try giving your code full addresses to your cells? Besides, it is a good idea not using the select command. Here's my modifications to your code:
Sub Hide_Projects()
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Put the name of your sheet here")
For i = 6 To 350
If .Cells(9, i).Text = "Project" Then
.Columns(i).Hidden = True
Else
.Columns(i).Hidden = False
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Your second code would look like this:
Sub Hide_Projects_5yr()
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Put the name of your second sheet here")
For i = 6 To 350
If .Cells(i, 7).Text = "Project" Then
.Rows(i).Hidden = True
Else
.Rows(i).Hidden = False
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Let me know if the error message keeps appearing.
Your main slowdown is a result of reading data from the worksheet too many times. Load the cell values into an array first, then loop through that.
You can also gain a bit of speed by unhiding the rows all at once at the outset, then hiding if the "="Project" condition is true. Again, this reduces the number of calls to the worksheet; your current version sets the ".Hidden" property of each row one-by-one.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim tempArr As Variant
tempArr = Range(Cells(6, 7), Cells(350, 7)).Value
Rows("6:350").Hidden = False
j = 1
For i = LBound(tempArr, 1) To UBound(tempArr, 1)
If tempArr(i, 1) = "Project" Then
Rows(j + 5).Hidden = True
End If
j = j + 1
Next
Application.ScreenUpdating = True
If you're really concerned about speed, you could also reduce the number of trips to the worksheet by checking for consecutive rows containing "Project". This version runs ~2x as fast as the other one (tested on a sample of 200k rows). It makes the code a lot more complex, though.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim k As Long
Dim tempArr As Variant
Dim consBool As Boolean
tempArr = Range(Cells(6, 7), Cells(350, 7)).Value
Rows("6:350").Hidden = False
j = 1
For i = LBound(tempArr, 1) To UBound(tempArr, 1)
consBool = True
If tempArr(i, 1) = "Project" Then
k = i
Do Until consBool = False
If k = UBound(tempArr, 1) Then
consBool = False
ElseIf tempArr(k + 1, 1) = "Project" Then
k = k + 1
Else
consBool = False
End If
Loop
Rows(j + 5 & ":" & k + 5).Hidden = True
j = j + 1 + (k - i)
i = k
Else
j = j + 1
End If
Next
Application.ScreenUpdating = True
Here's what it'd look like if I were going to implement this in a larger project. Among other optimizations, I've added some features (it can check for partial matches, check multiple columns for your criteria, and do an "inverted" mode that hides all rows not containing your criteria) and made sure that you're required to specify your worksheet.
Option Explicit
Sub exampleMacro()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Call hideRows(ThisWorkbook.Sheets("Example WS"), 6, 350, "Project", 7, 7)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub hideRows(ws As Worksheet, startRow As Long, endRow As Long, valCrit As String, Optional startCol As Long = 1, Optional endCol As Long = 1, Optional invert As Boolean = False, Optional checkAll As Boolean = False)
'Hides rows in a range (startRow to endRow) in a worksheet (ws)
'Hides when row contains a value (valCrit; partial strings are accepted) in a column or series of columns (startCol to endCol)
'In inverted mode (invert), hides rows that do *not* contain value
'If (checkAll) is True, all columns must contain value to be hidden/unhidden
'Usage examples:
'Call hideRows(exampleWS, 1, 1000, "Foo", 1, 10) -> hides rows that contain a cell in columns 1-10 with exact value "Foo"
'Call hideRows(exampleWS, 1, 1000, "*Foo*", 1, 10) -> hides rows that contain a cell in columns 1-10 that contains partial string "*Foo*"
'Call hideRows(exampleWS, 1, 1000, "Foo", 1, 10, True) -> hides rows that contain no cells in columns 1-10 with exact value "Foo"
'Call hideRows(exampleWS, 1, 1000, "Foo", 1, 10, False, True) -> hides rows in which all cells in columns 1-10 contain the exact value "Foo"
'Call hideRows(exampleWS, 1, 1000, "Foo", 1, 10, True, True) -> hides rows in which no cells in columns 1-10 contain the exact value "Foo"
Dim loopCounter As Long
Dim rowCounter As Long
Dim colCounter As Long
Dim endConsRow As Long
Dim tempArr As Variant
Dim toAdd As Long
Dim toHide As String
Dim consBool As Boolean
Dim tempBool As Boolean
Dim rowStr As String
Dim goAhead As Boolean
Dim i As Long
If startRow > endRow Then
toAdd = endRow - 1
Else
toAdd = startRow - 1
End If
ws.Rows(startRow & ":" & endRow).Hidden = False
tempArr = ws.Range(ws.Cells(startRow, startCol), ws.Cells(endRow, endCol)).Value
loopCounter = 1
For rowCounter = LBound(tempArr, 1) To UBound(tempArr, 1)
For colCounter = LBound(tempArr, 2) To UBound(tempArr, 2)
goAhead = False
If tempArr(rowCounter, colCounter) Like valCrit Then
If (Not checkAll) Or (colCounter = UBound(tempArr, 2)) Then
If invert Then
loopCounter = loopCounter + 1
Exit For
End If
goAhead = True
End If
ElseIf checkAll Or colCounter = UBound(tempArr, 2) Then
If Not invert Then
loopCounter = loopCounter + 1
Exit For
End If
goAhead = True
End If
If goAhead Then
endConsRow = rowCounter
consBool = True
Do Until consBool = False
tempBool = False
For i = LBound(tempArr, 2) To UBound(tempArr, 2)
If endConsRow = UBound(tempArr, 1) Then
Exit For
ElseIf tempArr(endConsRow + 1, i) Like valCrit Then
If (Not checkAll) Or (i = UBound(tempArr, 2)) Then
If Not invert Then
endConsRow = endConsRow + 1
tempBool = True
End If
Exit For
End If
ElseIf checkAll Or i = UBound(tempArr, 2) Then
If invert Then
endConsRow = endConsRow + 1
tempBool = True
End If
Exit For
End If
Next
If Not tempBool Then
consBool = False
End If
Loop
rowStr = loopCounter + toAdd & ":" & endConsRow + toAdd
If toHide = "" Then
toHide = rowStr
ElseIf Len(toHide & "," & rowStr) > 255 Then
ws.Range(toHide).EntireRow.Hidden = True
toHide = rowStr
Else
toHide = toHide & "," & rowStr
End If
loopCounter = loopCounter + 1 + (endConsRow - rowCounter)
rowCounter = endConsRow
Exit For
End If
Next
Next
If Not toHide = "" Then
ws.Range(toHide).EntireRow.Hidden = True
End If
End Sub
Dim t As Long
Dim u As Long
Dim v As Long
Dim q As Long
Dim p As Long
t = 1
u = 1
Do
If Sheet2.Range("D" & t).Value = "" Then
If Sheet2.Range("D" & t + 1).Value = "" Then
If Sheet2.Range("D" & t + 2).Value = "" Then
If Sheet2.Range("D" & t + 3).Value = "" Then
If Sheet2.Range("D" & t + 4).Value = "" Then
If Sheet2.Range("C" & t).Value = "" Then
Exit Do
End If
End If
End If
End If
End If
End If
If Not Sheet2.Range("D" & t).Value = "" Then
If Not Sheet2.Range("D" & t).Value = "Description" Then
v = Sheet2.Range("A" & 1 & ":" & "A" & t - 1).Height
q = Sheet2.Range("A" & t).Height
p = v + (q / 2) - 5
Set obj = Sheet2.OLEObjects.Add("Forms.checkbox.1")
With obj
.Width = 10
.Top = p
.Left = 875
.Height = 10
End With
u = u + 1
End If
End If
t = t + 1
Loop
This Code will help me to create many active-x check boxes as per my requirement as u can see in the image.
check the image,after i click the necessary check boxes,and then the command button "export the nfr", the row corresponding to the selected check box should be copied to another sheet, is there any way to add codes for that manipulation
sorry for editing the question
https://i.stack.imgur.com/YF2U2.png
Use a "custom" check box, by creating an event sunk class, such as this, clsCustomCheckBox
Option Explicit
Public WithEvents cb As msforms.CheckBox
Public Sub init(cbInit As msforms.CheckBox)
Set cb = cbInit
End Sub
Private Sub cb_Click() ' or the _Change event....
' Your code here
End Sub
You could then add your new ones, afterwards doing something similar to the below
Private c As Collection
Sub testcb()
Dim o As Object
Dim cb As New clsCustomCheckBox
Set o = ActiveSheet.OLEObjects(1)
cb.init o.Object
Set c = New Collection
c.Add cb
End Sub
you could switch to a Form Control instead of an ActiveX one and take advantage of its OnAction property and assign the same sub to all checkboxes
as follows:
Sub Macro2()
Dim t As Long, u As Long, v As Long, q As Long, p As Long
t = 2 '<--| start from 2 otherwise subsequent "A" & (t - 1) would return "A0"!
u = 1
With Sheet2
Do
If WorksheetFunction.CountA(.Cells(t, "D").Resize(5), .Cells(t, "C")) < 6 Then Exit Do
If Not .Cells(t, "D").Value = "Description" Then
v = .Range("A1", "A" & (t - 1)).Height
q = .Cells(t, "A").Height
p = v + (q / 2) - 5
With .CheckBoxes.Add(875, p, 10, 10) '<--| add a 'Form' checkbox
.OnAction = "CheckBoxClick" '<--| current checkbox will "react" calling 'CheckBoxClick()' sub
End With
u = u + 1 '<--| what is this for?
End If
t = t + 1
Loop
End With
End Sub
then you only have to type your CheckBoxClick() sub, for instance:
Sub CheckBoxClick()
With ActiveSheet.CheckBoxes(Application.Caller) '<--| reference caller checkbox
MsgBox "hello from " & .Name & " place at cell " & .TopLeftCell.Address
End With
End Sub
I want to add many option button to an excel worksheet (not to a VBA-form) and want to group them by row. The result should look something like this:
Here is the code I'm using so far:
For d = 1 To 31
Set checkboxKrankCell = Range("H" + Trim(Str(d)))
Set checkboxUrlaubCell = Range("I" + Trim(Str(d)))
Set checkboxJazCell = Range("J" + Trim(Str(d)))
groupWidth = checkboxKrankCell.Width + checkboxUrlaubCell.Width + checkboxJazCell.Width
Set groupBoxOptionButtons = ActiveSheet.GroupBoxes.Add(checkboxKrankCell.Left - 1, checkboxKrankCell.Top - 2, groupWidth + 1, checkboxKrankCell.Height)
With groupBoxOptionButtons
.Name = "GroupBox_" + Trim(Str(d))
.Caption = ""
End With
Set checkboxKrank = ActiveSheet.OptionButtons.Add(checkboxKrankCell.Left, checkboxKrankCell.Top - 1, checkboxKrankCell.Width, checkboxKrankCell.Height)
With checkboxKrank
.Caption = ""
End With
#1 checkboxKrank.GroupBox = groupBoxOptionButtons
Set checkboxUrlaub = ActiveSheet.OptionButtons.Add(checkboxUrlaubCell.Left, checkboxUrlaubCell.Top - 1, checkboxUrlaubCell.Width, checkboxUrlaubCell.Height)
With checkboxUrlaub
.Caption = ""
End With
Set checkboxJaz = ActiveSheet.OptionButtons.Add(checkboxJazCell.Left, checkboxJazCell.Top - 1, checkboxJazCell.Width, checkboxJazCell.Height)
With checkboxJaz
.Caption = ""
#2 .GroupBox = groupBoxOptionButtons
End With
Next d
I would expect to assign the option buttons to the group for the current row by setting the GroupBox property (see #1 or #2).
But both methods just gave me an error saying 'The object does not support the property or methode'.
Any help or hint is welcome ;-)
Based on the tip from snb I have modified my function like this:
Sub AddOptionButtons()
ActiveSheet.OptionButtons.Delete
For d = 1 To 31
Set checkboxKrankCell = Range("H" + Trim(Str(d + 4)))
Set checkboxUrlaubCell = Range("I" + Trim(Str(d + 4)))
Set checkboxJazCell = Range("J" + Trim(Str(d + 4)))
option1Name = "Krank_" + Trim(Str(d))
option2Name = "Urlaub_" + Trim(Str(d))
option3Name = "Jaz_" + Trim(Str(d))
Set checkboxKrank = ActiveSheet.OptionButtons.Add(checkboxKrankCell.Left, checkboxKrankCell.Top - 1, checkboxKrankCell.Width, checkboxKrankCell.Height)
With checkboxKrank
.Caption = ""
.Name = option1Name
End With
Set checkboxUrlaub = ActiveSheet.OptionButtons.Add(checkboxUrlaubCell.Left, checkboxUrlaubCell.Top - 1, checkboxUrlaubCell.Width, checkboxUrlaubCell.Height)
With checkboxUrlaub
.Caption = ""
.Name = option2Name
End With
Set checkboxJaz = ActiveSheet.OptionButtons.Add(checkboxJazCell.Left, checkboxJazCell.Top - 1, checkboxJazCell.Width, checkboxJazCell.Height)
With checkboxJaz
.Caption = ""
.Name = option3Name
End With
ActiveSheet.Shapes.Range(Array(option1Name, option2Name, option3Name)).Group
Next d
End Sub
I don't get any errors using Shapes.Range(...).Group.
But still all option buttons from on the sheet are all mutual exclusive.
Seems grouping does not work here.
Try the following code on an empty workbook. It will give you an option to choose only ONE optionbutton on each row, which is what you want, as far as I understood (I also created a linked cell reference, just in case you would like to take further action, given the choice of a user.):
Sub AddOptionButtons()
Dim btn1 As OptionButton
Dim btn2 As OptionButton
Dim btn3 As OptionButton
Dim grbox As GroupBox
Dim t As Range
Dim s As Range
Dim p As Range
Dim i As Integer
ActiveSheet.OptionButtons.Delete
ActiveSheet.GroupBoxes.Delete
For i = 5 To 35 Step 1
Set t = ActiveSheet.Range(Cells(i, 8), Cells(i, 8))
Set s = ActiveSheet.Range(Cells(i, 9), Cells(i, 9))
Set p = ActiveSheet.Range(Cells(i, 10), Cells(i, 10))
Set btn1 = ActiveSheet.OptionButtons.Add(t.Left, t.Top, t.Width, t.Height)
Set btn2 = ActiveSheet.OptionButtons.Add(s.Left, s.Top, s.Width, s.Height)
Set btn3 = ActiveSheet.OptionButtons.Add(p.Left, p.Top, p.Width, p.Height)
Set grbox = ActiveSheet.GroupBoxes.Add(t.Left, t.Top, t.Width + 100, t.Height)
With btn1
.Caption = ""
.Display3DShading = True
.LinkedCell = "M" & i
End With
With btn2
.Caption = ""
.Display3DShading = True
End With
With btn3
.Caption = ""
.Display3DShading = True
End With
With grbox
.Caption = ""
.Visible = False
End With
Next i
End Sub
I'd use:
Sub M_snb()
ReDim sn(2)
For j = 1 To 2
For jj = 1 To 3
With Sheet1.OptionButtons.Add(Cells(j, jj).Left, Cells(j, jj).Top - 1, Cells(j, jj).Width, Cells(j, jj).Height)
sn(jj - 1) = .Name
End With
Next
Sheet1.Shapes.Range(sn).Group
Next
End Sub
I have the following basic script that merges cells with the same value in Column R
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("R1:R1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
What I would like to do is repeat this in columns A:Q and S:T but, I would like these columns to be merged in the same merged cell ranges as column R, i.e. if R2:R23 is merged then A2:A23, B2:B23, C2:C23 etc. will also be merge.
Columns A:Q do not contain values, column S:T have values but, these will be the same values throughout the range.
Any ideas
Apols for the earlier edit - this now deals with more than one duplicate in col R.
Note that this approach will work on the current (active) sheet.
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cval As Variant
Dim currcell As Range
Dim mergeRowStart As Long, mergeRowEnd As Long, mergeCol As Long
mergeRowStart = 1
mergeRowEnd = 1000
mergeCol = 18 'Col R
For c = mergeRowStart To mergeRowEnd
Set currcell = Cells(c, mergeCol)
If currcell.Value = currcell.Offset(1, 0).Value And IsEmpty(currcell) = False Then
cval = currcell.Value
strow = currcell.Row
endrow = strow + 1
Do While cval = currcell.Offset(endrow - strow, 0).Value And Not IsEmpty(currcell)
endrow = endrow + 1
c = c + 1
Loop
If endrow > strow+1 Then
Call mergeOtherCells(strow, endrow)
End If
End If
Next c
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub mergeOtherCells(strw, enrw)
'Cols A to T
For col = 1 To 20
Range(Cells(strw, col), Cells(enrw, col)).Merge
Next col
End Sub
You can try the below code as well. It would require you to put a 'No' after the last line in column R (R1001) so as to end the while loop.
Sub Macro1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
flag = False
k = 1
While ActiveSheet.Cells(k, 18).Value <> "No"
i = 1
j = 0
While i < 1000
rowid = k
If Cells(rowid, 18).Value = Cells(rowid + i, 18).Value Then
j = j + 1
flag = True
Else
i = 1000
End If
i = i + 1
Wend
If flag = True Then
x = 1
While x < 21
Range(Cells(rowid, x), Cells(rowid + j, x)).Merge
x = x + 1
Wend
flag = False
k = k + j
End If
k = k + 1
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I would like to filter a Listbox created from a list of values stored in a worksheet depending on text written in a textbox contained in the same userform.
My Listbox has 4 or 5 columns (depending on OptionField selection) and I would like to search all the columns for the text written.
Example: I write "aaa" in TextField and the Listbox should return a list based on all the lines whose column 1 or 2 or 3 or 4 or 5 contain "aaa".
Below my code to refresh the list on OptionField selection (this code does not produce any error, it is just to show how I create my list):
Sub RefreshList()
Dim selcell, firstcell As String
Dim k, i As Integer
Dim r as long
i = 0
k = 0
' reads parameters from hidden worksheet
If Me.new_schl = True Then
firstcell = Cells(3, 4).Address
selcell = firstcell
Do Until IsEmpty(Range("" & selcell & "")) And i = 2
If IsEmpty(Range("" & selcell & "")) Then i = i + 1
k = k + 1
selcell = Cells(1 + k, 7).Address(0, 0)
Loop
k = k - 1
selcell = Cells(1 + k, 7).Address(0, 0)
With Me.ListBox1
.ColumnCount = 4
.ColumnWidths = "50; 80; 160; 40"
.RowSource = ""
Set MyData = Range("" & firstcell & ":" & selcell & "")
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 3) = "" Or .List(r, 3) = "0" Then
.RemoveItem r
End If
Next r
End With
Else
firstcell = Cells(3, 11).Address
selcell = firstcell
Do Until IsEmpty(Range("" & selcell & "")) And i = 11
If IsEmpty(Range("" & selcell & "")) Then i = i + 1
k = k + 1
selcell = Cells(1 + k, 15).Address(0, 0)
Loop
k = k - 1
selcell = Cells(1 + k, 15).Address(0, 0)
With Me.ListBox1
.ColumnCount = 5
.ColumnWidths = "40; 40; 160; 40; 40"
.RowSource = ""
Set MyData = Range("" & firstcell & ":" & selcell & "")
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 3) = "" Or .List(r, 3) = "0" Then
.RemoveItem r
End If
Next r
End With
End If
End Sub
Finally I could come out with something!
Sub Filter_Change()
Dim i As Long
Dim Str As String
Str = Me.Filter.Text
Me.RefreshList
If Not Str = "" Then
With Me.ListBox1
For i = .ListCount - 1 To 0 Step -1
If InStr(1, LCase(.List(i, 0)), LCase(Str)) = 0 And InStr(1, LCase(.List(i, 1)), LCase(Str)) = 0 And _
InStr(1, LCase(.List(i, 2)), LCase(Str)) = 0 And InStr(1, LCase(.List(i, 3)), LCase(Str)) = 0 Then
.RemoveItem i
End If
Next i
End With
End If
End Sub
I know, the answer is couple of years old...
But I thought I'd share solution that works the best for me, because the filter is blazing fast even when there are thousands of items in the list. It is not without a "catch", though:
it uses a Dictionary object
Option Explicit
Dim myDictionary As Scripting.Dictionary
Private Sub fillListbox()
Dim iii As Integer
Set myDictionary = New Scripting.Dictionary
' this, here, is just a "draft" of a possible loop
' for filling in the dictionary
For iii = 1 To RANGE_END
If Not myDictionary.Exists(UNIQUE_VALUE) Then
myDictionary.Add INDEX, VALUE
End If
Next
myListbox.List = myDictionary .Items
End Sub
Private Sub textboxSearch_Change()
Dim Keys As Variant
Keys = myDictionary .Items
myListbox.List = Filter(Keys, textboxSearch.Text, True, vbTextCompare)
End Sub
Private Sub UserForm_Initialize()
Call fillListbox
End Sub