Me.ListBox1.Clear 产生 运行 时间错误 '- 2147467259(80004005)': Unspecified error
Me.ListBox1.Clear produces Run time error '- 2147467259(80004005)': Unspecified error
我们有 4000 种不同的 materials/equipment 库存。
我们使用 VBA 库存宏，与条形码扫描仪集成，使所有库存过程。
由于 VBA 代码，我们将所有不同的 materials/equipments 分别汇总到另一个工作簿（假设 Summary Workbook）。
要查看我们库存中有多少种不同的管道和多少米的管道，您应该单击摘要工作簿中的 "PIPES" sheet。
"ELECTRICAL MATERIALS"、"FLANGES"、"FITTINGS"、"ASSETS"等近20个个股同理。
所有的标题都是分开的，都是不同页面的列表。
我还把所有的标题（"ELECTRICAL MATERIALS"、"FLANGES"、"FITTINGS"、"ASSETS"、"PIPES"等）都列到了另一个sheet（假设 DATA Sheet）。
大意是：用这个sheet作为数据列表。
以上所有操作的目的都是为了方便地检查materials/equipment数量以及我们库存中有多少种不同的产品。但是当你打开 "Summary Workbook" 时，检查起来很复杂。每个股票组至少包含 150 个不同的 materials/equipment.
所以我在 Summary Workbook 中创建了另一个 sheet 并将其命名为 Main Sheet。
此外，我在其中创建了一个文本框和一个列表框。
我选择DATAsheet里面的所有股票信息来自(A2:F4214)，命名为"DATA".
因此，当我选择主要 sheet 上的列表框时，我使用 "ListFillRange" 方法传输所有 "DATA"。
我使用 6 列标题。
1- 数
2-条码编号
3-股票组名称
4- 股票名称
5-库存数量
6- 库存计量（米、件、套、升等）
将文本框用作搜索框的代码：
Private Sub TextBox1_Change()
Dim i As Long
Me.TextBox1.Text = StrConv(Me.TextBox1.Text, 1)
Me.ListBox1.Clear
For i = 2 To Application.WorksheetFunction.CountA(Sayfa281.Range("D:D"))
a = Len(Me.TextBox1.Text)
If Sayfa281.Cells(i, 4).Value Like "*" & TextBox1.Text & "*" Then
Me.ListBox1.AddItem Sayfa281.Cells(i, 4).Value
Me.ListBox1.List(ListBox1.ListCount - 1, 4) = Sayfa281.Cells(i, 4).Value
End If
Next i
End Sub
它给出了：
Run time error '- 2147467259(80004005)':
Unspecified error.
当我点击 DEBUG 时，它以黄色显示 Me.ListBox1.Clear。
当我在用户窗体中使用上面的代码时它有效，但在 Excel sheet 中它没有。
根据评论和 this mrexcel.com link，似乎 80004005 运行 次错误是由于使用 .ListFillRange 初始化列表框，它绑定了将列表框添加到工作簿中的特定范围，并使其 "illegal" 从列表框中删除任何项目（通过 .RemoveItem 或 .Clear）。
如果不使用.ListFillRange，则必须手动配置列表框的列。下面是一些可以在文本框的 Change 事件处理程序中使用的代码来完成此操作。这段代码有点通用，因此可以很容易地调整到任何数据 sheet。此代码的一个更简单版本将简单地将列表框的 .ColumnWidths 属性 设置为硬编码字符串，这将基本上消除对 Dim c as Long 之后和 [=17= 之前的所有代码的需要], 但我相信这段代码使列表框更灵活地适应源数据的变化 sheet ...
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("DataSheet") '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 = 0
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
'NB: This array will store the data in transposed form (rows and columns inverted) so that it can be easily
' resized later using ReDim Preserve, which only allows you to resize the last dimension
ReDim filteredArr(1 To colCount, 1 To UBound(dataArr, 1)) '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
'Inverting rows and columns in [filteredArr] in preparation for the later ReDim Preserve
filteredArr(c, filteredCount) = dataArr(r, c)
Next
continue_for_r:
Next
'Copy [filteredArr] to the listbox, removing the excess rows first
If filteredCount > 0 Then
ReDim Preserve filteredArr(1 To colCount, 1 To filteredCount)
Me.ListBox1.Column = filteredArr
'Used .Column instead of .List above, as per advice at
'
End If
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
如果不再使用 .ListFillRange，列表框开始时将为空，只有在用户开始向文本框输入内容后才会填充。目前，如果用户编辑然后清除文本框，整个数据 sheet 将加载到列表框，但可以通过在重置列表框的代码块后添加 If filterSt = "" Then GoTo exit_sub 轻松更改这种行为。
代码尝试通过在开始时将整个数据 sheet 读入内存而不是一次读取数据 sheet 一个单元格来更快地加载数据。它还避免使用列表框的 .AddItem 方法来一次加载整个列表并绕过该方法的 10 列限制，如 中所述（10 列限制可能成为一个问题，如果colCount 的值在未来会增加）。
该代码使用了 2 个数组。第一个数组将所有数据 sheet 行加载到内存中，第二个数组复制满足过滤条件的行。在第二个数组中，行和列是倒置的，因此可以在最后使用 ReDim Preserve 轻松调整它的大小（在我们知道要保留在数组中的最终数据行数之后）。需要这种转置是因为 ReDim Preserve 只允许您调整最后一个维度的大小，如 this Whosebug answer. Thanks, @T.M., for the advice at this Whosebug answer!
中所述
对于像我这样的初学者，您无法想象您的帮助是多么值得。
非常感谢。
代码运行良好。
我也要问你一件小事
每次输入文本框，我的列表框越来越小
事实仍然是信息相互交织。
我尝试更改代码下方的一些参数，
'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 = 0
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
我无法实现。
你对此有什么建议吗
祝你有美好的一天。
对于列表框缩小的bug，您可以进行以下处理。
ListBox1.Width = 1000
ListBox1.Height = 800
就在离开潜艇之前。它对我有用。
感谢@macrobook 和@NoahBridge。
下面的代码适合我。
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 = 750
ListBox1.Width = 1800
ListBox1.Top = 100
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
我们有 4000 种不同的 materials/equipment 库存。
我们使用 VBA 库存宏，与条形码扫描仪集成，使所有库存过程。
由于 VBA 代码，我们将所有不同的 materials/equipments 分别汇总到另一个工作簿（假设 Summary Workbook）。
要查看我们库存中有多少种不同的管道和多少米的管道，您应该单击摘要工作簿中的 "PIPES" sheet。
"ELECTRICAL MATERIALS"、"FLANGES"、"FITTINGS"、"ASSETS"等近20个个股同理。
所有的标题都是分开的，都是不同页面的列表。
我还把所有的标题（"ELECTRICAL MATERIALS"、"FLANGES"、"FITTINGS"、"ASSETS"、"PIPES"等）都列到了另一个sheet（假设 DATA Sheet）。
大意是：用这个sheet作为数据列表。
以上所有操作的目的都是为了方便地检查materials/equipment数量以及我们库存中有多少种不同的产品。但是当你打开 "Summary Workbook" 时，检查起来很复杂。每个股票组至少包含 150 个不同的 materials/equipment.
所以我在 Summary Workbook 中创建了另一个 sheet 并将其命名为 Main Sheet。 此外，我在其中创建了一个文本框和一个列表框。
我选择DATAsheet里面的所有股票信息来自(A2:F4214)，命名为"DATA".
因此，当我选择主要 sheet 上的列表框时，我使用 "ListFillRange" 方法传输所有 "DATA"。
我使用 6 列标题。
1- 数
2-条码编号
3-股票组名称
4- 股票名称
5-库存数量
6- 库存计量（米、件、套、升等）
将文本框用作搜索框的代码：
Private Sub TextBox1_Change()
Dim i As Long
Me.TextBox1.Text = StrConv(Me.TextBox1.Text, 1)
Me.ListBox1.Clear
For i = 2 To Application.WorksheetFunction.CountA(Sayfa281.Range("D:D"))
a = Len(Me.TextBox1.Text)
If Sayfa281.Cells(i, 4).Value Like "*" & TextBox1.Text & "*" Then
Me.ListBox1.AddItem Sayfa281.Cells(i, 4).Value
Me.ListBox1.List(ListBox1.ListCount - 1, 4) = Sayfa281.Cells(i, 4).Value
End If
Next i
End Sub
它给出了：
Run time error '- 2147467259(80004005)':
Unspecified error.
当我点击 DEBUG 时，它以黄色显示 Me.ListBox1.Clear。
当我在用户窗体中使用上面的代码时它有效，但在 Excel sheet 中它没有。
根据评论和 this mrexcel.com link，似乎 80004005 运行 次错误是由于使用 .ListFillRange 初始化列表框，它绑定了将列表框添加到工作簿中的特定范围，并使其 "illegal" 从列表框中删除任何项目（通过 .RemoveItem 或 .Clear）。
如果不使用.ListFillRange，则必须手动配置列表框的列。下面是一些可以在文本框的 Change 事件处理程序中使用的代码来完成此操作。这段代码有点通用，因此可以很容易地调整到任何数据 sheet。此代码的一个更简单版本将简单地将列表框的 .ColumnWidths 属性 设置为硬编码字符串，这将基本上消除对 Dim c as Long 之后和 [=17= 之前的所有代码的需要], 但我相信这段代码使列表框更灵活地适应源数据的变化 sheet ...
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("DataSheet") '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 = 0
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
'NB: This array will store the data in transposed form (rows and columns inverted) so that it can be easily
' resized later using ReDim Preserve, which only allows you to resize the last dimension
ReDim filteredArr(1 To colCount, 1 To UBound(dataArr, 1)) '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
'Inverting rows and columns in [filteredArr] in preparation for the later ReDim Preserve
filteredArr(c, filteredCount) = dataArr(r, c)
Next
continue_for_r:
Next
'Copy [filteredArr] to the listbox, removing the excess rows first
If filteredCount > 0 Then
ReDim Preserve filteredArr(1 To colCount, 1 To filteredCount)
Me.ListBox1.Column = filteredArr
'Used .Column instead of .List above, as per advice at
'
End If
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
如果不再使用 .ListFillRange，列表框开始时将为空，只有在用户开始向文本框输入内容后才会填充。目前，如果用户编辑然后清除文本框，整个数据 sheet 将加载到列表框，但可以通过在重置列表框的代码块后添加 If filterSt = "" Then GoTo exit_sub 轻松更改这种行为。
代码尝试通过在开始时将整个数据 sheet 读入内存而不是一次读取数据 sheet 一个单元格来更快地加载数据。它还避免使用列表框的 .AddItem 方法来一次加载整个列表并绕过该方法的 10 列限制，如 colCount 的值在未来会增加）。
该代码使用了 2 个数组。第一个数组将所有数据 sheet 行加载到内存中，第二个数组复制满足过滤条件的行。在第二个数组中，行和列是倒置的，因此可以在最后使用 ReDim Preserve 轻松调整它的大小（在我们知道要保留在数组中的最终数据行数之后）。需要这种转置是因为 ReDim Preserve 只允许您调整最后一个维度的大小，如 this Whosebug answer. Thanks, @T.M., for the advice at this Whosebug answer!
对于像我这样的初学者，您无法想象您的帮助是多么值得。
非常感谢。
代码运行良好。 我也要问你一件小事
每次输入文本框，我的列表框越来越小
事实仍然是信息相互交织。
我尝试更改代码下方的一些参数，
'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 = 0
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
我无法实现。 你对此有什么建议吗
祝你有美好的一天。
对于列表框缩小的bug，您可以进行以下处理。
ListBox1.Width = 1000
ListBox1.Height = 800
就在离开潜艇之前。它对我有用。
感谢@macrobook 和@NoahBridge。
下面的代码适合我。
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 = 750
ListBox1.Width = 1800
ListBox1.Top = 100
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