|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Option Explicit
- Dim iOption() As New clsOption
- Dim i&
- Public Sub 筛选查询条目()
- Dim s
- d.RemoveAll
- For i = 4 To UBound(arr)
- s = Trim(arr(i, c))
- If s <> "" And s <> 0 And InStr(1, s, TextBox1.Text, 1) Then
- If Not d.Exists(s) Then
- d(s) = i
- Else
- d.Item(s) = d.Item(s) & "|" & i
- End If
- End If
- Next
- ListBox1.List = d.keys
- End Sub
- Private Sub ListBox1_Click()
- Dim k, kk, j%, n%
- kk = Split(d.Item(ListBox1.Text), "|")
- ReDim a(1 To 19, 1 To UBound(kk) + 1)
- For Each k In kk
- n = n + 1
- For j = 1 To 10
- a(j, n) = arr(Val(k), j + 3)
- Next
- For j = 13 To 18
- a(j, n) = arr(Val(k), j + 2)
- Next
- a(19, n) = arr(Val(k), 14)
- '差数、差件对应关系不明确
- Next
- Application.ScreenUpdating = False
- Sheet3.Range("B2").Resize(1, 2) = Array(Key & ":", ListBox1.Text)
- With Sheet3.Range("B5:T65536")
- .ClearContents
- .Borders.LineStyle = xlNone
- End With
- With Sheet3.Range("B5").Resize(n, 19)
- .Value = WorksheetFunction.Transpose(a)
- .Borders.LineStyle = xlContinuous
- End With
- Application.ScreenUpdating = True
- End Sub
- Private Sub TextBox1_Change()
- Call 筛选查询条目
- End Sub
- Private Sub UserForm_Initialize()
- Dim Ctl As Control, n%
- arr = Sheet1.Range("A1:V" & Sheet1.Range("B" & Rows.Count).End(3).Row)
- Set d = CreateObject("Scripting.Dictionary")
- For Each Ctl In Me.Controls
- If TypeName(Ctl) = "OptionButton" Then
- n = n + 1: ReDim Preserve iOption(1 To n)
- iOption(n).Attach Ctl
- End If
- Next
- Option1.Value = True
- <font color="#ff0000"> With ListBox1 '这里定义了可以多选后还要如何改代码才能实现真正的多选查询?????
- .ListStyle = fmListStyleOption
- .MultiSelect = fmMultiSelectMulti
- End With</font>
- End Sub
- Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
- c = 0: Erase arr
- Set d = Nothing
- End Sub
复制代码 目前附件是单选执行,如何才能改为多选也能查询???
成品库查询(优秀作品)示例.rar
(1.88 MB, 下载次数: 34)
|
|