excel - 文本框搜索栏和列表框 - 4
问题描述
我有一个简单的股票列表,它使用一个文本框和一个列表框。当我向文本框(如法兰)写一个单词时,我可以在列表框中看到每个包含相同单词的股票名称。(我可以在列表框中看到每个包含法兰字的股票名称。)
下面的代码在我的电脑上运行良好。
但是当我将这个 excel 表发送到另一台计算机时,当我键入任何键盘键时,列表框变得越来越小。
我怎样才能避免这个错误?我怎样才能在每个人的电脑上使用这个 Excel 表而不会出现这个问题?有人有想法吗?
Private Sub TextBox1_Change()
'To avoid any screen update until the process is finished
Application.ScreenUpdating = False
'This method must make sure to turn this property back to True before exiting by
' always going through the exit_sub label
On Error GoTo err_sub
'This will be the string to filter by
Dim filterSt As String: filterSt = Me.TextBox1.Text & ""
'This is the number of the column to filter by
Const filterCol As Long = 4 'This number can be changed as needed
'This is the sheet to load the listbox from
Dim dataSh As Worksheet: Set dataSh = Worksheets("T?mListe") 'The sheet name can be changed as needed
'This is the number of columns that will be loaded from the sheet (starting with column A)
Const colCount As Long = 6 'This constant allows you to easily include more/less columns in future
'Determining how far down the sheet we must go
Dim usedRng As Range: Set usedRng = dataSh.UsedRange
Dim lastRow As Long: lastRow = usedRng.Row - 1 + usedRng.Rows.Count
Dim c As Long
'Getting the total width of all the columns on the sheet
Dim colsTotWidth As Double: colsTotWidth = 0
For c = 1 To colCount
colsTotWidth = colsTotWidth + dataSh.Columns(c).ColumnWidth
Next
'Determining the desired total width for all the columns in the listbox
Dim widthToUse As Double
'Not sure why, but subtracting 4 ensured that the horizontal scrollbar would not appear
widthToUse = Me.ListBox1.Width - 4
If widthToUse < 0 Then widthToUse = 0
'Making the widths of the listbox columns proportional to the corresponding column widths on the sheet;
' thus, the listbox columns will automatically adjust if the column widths on the sheet are changed
Dim colWidthSt As String: colWidthSt = "" 'This will be the string used to set the listbox's column widths
Dim totW As Double: totW = 1
For c = 1 To colCount
Dim w As Double
If c = colCount Then 'Use the remaining width for the last column
w = widthToUse - totW
Else 'Calculate a proportional width
w = dataSh.Columns(c).ColumnWidth / colsTotWidth * widthToUse
End If
'Rounding to 0 decimals and using an integer to avoid localisation issues
' when converting the width to a string
Dim wInt As Long: wInt = Round(w, 0)
If wInt < 1 And w > 0 Then wInt = 1
totW = totW + wInt
If c > 1 Then colWidthSt = colWidthSt & ","
colWidthSt = colWidthSt & wInt
Next
'Reset the listbox
Me.ListBox1.Clear
Me.ListBox1.ColumnCount = colCount
Me.ListBox1.ColumnWidths = colWidthSt
Me.ListBox1.ColumnHeads = False
'Reading the entire data sheet into memory
Dim dataArr As Variant: dataArr = dataSh.UsedRange
If Not IsArray(dataArr) Then dataArr = dataSh.Range("A1:A2")
'If filterCol is beyond the last column in the data sheet, leave the list blank and simply exit
If filterCol > UBound(dataArr, 2) Then GoTo exit_sub 'Do not use Exit Sub here, since we must turn ScreenUpdating back on
'This array will store the rows that meet the filter condition
ReDim filteredArr(1 To UBound(dataArr, 1), 1 To UBound(dataArr, 2)) 'Make room for the maximum possible size
Dim filteredCount As Long: filteredCount = 0
'Copy the matching rows from [dataArr] to [filteredArr]
'IMPORTANT ASSUMPTION: The first row on the sheet is a header row
Dim r As Long
For r = 1 To lastRow
'The first row will always be added to give the listbox a header
If r > 1 And InStr(1, dataArr(r, filterCol) & "", filterSt, vbTextCompare) = 0 Then
GoTo continue_for_r
End If
'NB: The Like operator is not used above in case [filterSt] has wildcard characters in it
' Also, the filtering above is case-insensitive
' (if needed, it can be changed to case-sensitive by changing the last parameter to vbBinaryCompare)
filteredCount = filteredCount + 1
For c = 1 To colCount
filteredArr(filteredCount, c) = dataArr(r, c)
Next
continue_for_r:
Next
'Copy [filteredArr] to a new array with the right dimensions
If filteredCount > 0 Then
'Unfortunately, Redim Preserve cannot be used here because it can only resize the last dimension;
' therefore, we must manually copy the filtered data to a new array
ReDim filteredArr2(1 To filteredCount, 1 To colCount)
For r = 1 To filteredCount
For c = 1 To colCount
filteredArr2(r, c) = filteredArr(r, c)
Next
Next
Me.ListBox1.List = filteredArr2
End If
ListBox1.Height = 772
ListBox1.Width = 1300
ListBox1.Top = 75
exit_sub:
Application.ScreenUpdating = True
Exit Sub
err_sub:
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & Err.Description
Resume exit_sub 'To make sure that screen updating is turned back on
End Sub
提前致谢。
解决方案
推荐阅读
- c - 带有两个 .c 文件且没有标题的 Makefile
- c# - 如何在 C# 中从远程获取面板屏幕
- c# - 无法从程序集“Firebase,版本=1.0.0.0,文化=中性,PublicKeyToken=null”加载类型“Firebase.Database.FirebaseObject`1”
- java - 数组中项目的比率总是返回零 ~ HackerRank Plus Minus Problem
- sails.js - 想在 mongodb 的水线中使用 _id 而不是 id
- javascript - 如何在正斜杠前添加字符串?
- python - 当 DEBUG = True 时如何更改 Bulk log 消息?
- html - 无法在表格上添加表格按钮行
- php - PHP如何使用where in替换mysql中的左连接?
- c++ - 任务按处理时间排序时,openMp动态调度和LPT调度一样吗?