VBA自学应用（2）——制作简单的数据录入窗口

现如今有两张表，一张产品表，一张录入表，如图所示。


我们要做出如下效果：

达成这样的效果其实也不难，就让我们一步步来！

一、画一个你的窗体

1. 首先在标签栏找到开发工具中的VB编辑器并打开

2. 然后右键新建一个用户窗体

3. 然后选中窗体模块，按F4打开窗体属性窗口（也可以在视图选项卡中打开），这里可以设置窗体的各种属性

4. 接下来在视图选项卡下找到工具箱，用工具箱画出所需要的控件

二、编写窗体代码

1. 先双击窗体，在如图所示的地方找到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

当然你也可以直接在列表框的属性窗口中设置他的属性

2. 第二步，按照上述方法找到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

3. 第三步，为你需要查找的项目进行模糊匹配设置代码

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

4. 第四步，为关闭和录入按钮编写代码

• 关闭

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