现如今有两张表,一张产品表,一张录入表,如图所示。
我们要做出如下效果:
达成这样的效果其实也不难,就让我们一步步来!
一、画一个你的窗体
- 首先在标签栏找到开发工具中的VB编辑器并打开
- 然后右键新建一个用户窗体
- 然后选中窗体模块,按F4打开窗体属性窗口(也可以在视图选项卡中打开),这里可以设置窗体的各种属性
- 接下来在视图选项卡下找到工具箱,用工具箱画出所需要的控件
二、编写窗体代码
- 先双击窗体,在如图所示的地方找到UserForm对应的事件(UserForm_Initialize=窗体名称_事件)
写入以下代码
Private Sub UserForm_Initialize()
arr = Sheets("产品表").Range("a1").CurrentRegion
With ListBox1
'设置列表框属性
.List = arr
.MultiSelect = fmMultiSelectExtended
.ColumnCount = UBound(arr, 2)
.ListStyle = fmListStyleOption
LISTBOX_Post_Flag = 1
LISTBOX_Mouse_Flag = 1
End With
End Sub
当然你也可以直接在列表框的属性窗口中设置他的属性
- 第二步,按照上述方法找到ListBox1_DblClick,写入以下代码
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'双击的时候也可以更改数据
Dim crr()
Dim m As Long
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
m = m + 1
ReDim Preserve crr(1 To ListBox1.ColumnCount, 1 To m)
For j = 0 To ListBox1.ColumnCount - 1
crr(j + 1, m) = ListBox1.List(i, j)
Next
End If
Next
If m > 0 Then ActiveCell.Resize(m, j) = Application.Transpose(crr)
End Sub
- 第三步,为你需要查找的项目进行模糊匹配设置代码
Private Sub TextBox1_Change()
'模糊匹配
Dim drr()
Dim n As Long
arr = Sheets("产品表").Range("A1").CurrentRegion
For i = 1 To UBound(arr)
If InStr(CStr(arr(i, 1)), TextBox1.Text) > 0 Then
n = n + 1
ReDim Preserve drr(1 To ListBox1.ColumnCount, 1 To n)
For j = 1 To UBound(arr, 2)
drr(j, n) = arr(i, j)
Next
End If
Next
If n > 1 Then
ListBox1.List = Application.Transpose(drr)
ElseIf n = 1 Then
ReDim crr(1 To 1, 1 To UBound(drr))
For i = 1 To UBound(drr)
crr(1, i) = drr(i, 1)
Next
ListBox1.List = crr
Else
ListBox1.Clear
End If
End Sub
- 第四步,为关闭和录入按钮编写代码
- 关闭
Private Sub CommandButton2_Click()
Unload Me
End Sub
- 录入
Private Sub CommandButton1_Click()
'录入
Dim brr(), grr
Dim k As Long, m As Long
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
k = k + 1
ReDim Preserve brr(1 To ListBox1.ColumnCount, 1 To k)
For j = 0 To ListBox1.ColumnCount - 1
brr(j + 1, k) = ListBox1.List(i, j)
'选中的数据存入数组brr
Next
End If
Next
If k = 0 Then MsgBox "请选择数据": Exit Sub
grr = Application.Transpose(brr)
If k > 0 Then
If k = 1 Then
For i = 1 To UBound(grr)
ActiveCell.Offset(, m) = grr(i)
m = m + 1
Next
ActiveCell.Offset(1).Select
Else
For i = 1 To UBound(grr)
For j = 1 To UBound(grr, 2)
ActiveCell.Offset(, m) = grr(i, j)
m = m + 1
Next
ActiveCell.Offset(1).Select
m = 0
Next
End If
End If
'取消选中
Cells(Rows.Count, "B").End(3).Offset(1).Select
End Sub
- 这里可以使用小技巧取消窗口自带的关闭按钮事件,找到对应事件键入以下代码就可以啦!
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode <> vbFormCode Then Cancel = True
End Sub
三、使用工作表事件激活窗体
右键双击对应工作表
按照找窗体事件的方法找到BeforeDoubleClick事件,代码如下
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("b5:b100")) Is Nothing Then Exit Sub
Cancel = True
UserForm1.Show Model
End Sub
四、补充:关于鼠标在listbox中的滚轮实现
相关代码请移步→列表框实现鼠标滚轮滚动Demo
- 首先,在上述代码的模块之下,定义一个变量,如图所示
- 第二步,将图示部分改成你定义的变量名称
- 最后,只需要在对应listbox的mousemove事件下键入如下代码即可以实现滚轮效果
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll
Set frmlistbox = Userform1.ListBox1
End Sub
Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll
Set frmlistbox = Userform1.ListBox2
End Sub