VBA窗体录入系统

Option Explicit

Private Sub bianhao_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

ListBox1.Visible = True '编号智能提示输入

ListBox1.Clear

Dim arr, arr1

arr = Range("a2", [a2].End(xlDown))

arr1 = Filter(Application.Transpose(arr), bianhao.Value, True)

ListBox1.List = arr1

End Sub

Private Sub UserForm_Initialize()

ListBox1.Visible = False '窗体隐藏列表框

ListBox2.Visible = False

ListBox3.Visible = False

ListBox4.Visible = False

    With ListBox1

        .Top = bianhao.Top + bianhao.Height

        .Left = bianhao.Left

        .Width = bianhao.Width

        .Height = 50

    End With

    With ListBox2

        .Top = xingming.Top + xingming.Height

        .Left = xingming.Left

        .Width = xingming.Width

        .Height = 50

    End With

    With ListBox3

        .Top = jiguan.Top + jiguan.Height

        .Left = jiguan.Left

        .Width = jiguan.Width

        .Height = 50

    End With

    With ListBox4

        .Top = zhiwu.Top + zhiwu.Height

        .Left = zhiwu.Left

        .Width = zhiwu.Width

        .Height = 50

    End With

End Sub

Private Sub xingming_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

ListBox2.Visible = True  '姓名智能提示输入

ListBox2.Clear

Dim arr, arr1

arr = Range("b2", [b2].End(xlDown))

arr1 = Filter(Application.Transpose(arr), xingming.Value, True)

ListBox2.List = arr1

End Sub

Private Sub jiguan_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

ListBox3.Visible = True '籍贯智能提示输入

ListBox3.Clear

On Error Resume Next

Dim arr, arr1, m%, d As New Dictionary '定义字典

    Set d = CreateObject("scripting.dictionary") '调用字典

    arr = Range("d2", [d2].End(xlDown))

    For m = 1 To UBound(arr)

        d.Add arr(m, 1), ""  '字典去重

    Next

    arr1 = Filter(d.Keys, jiguan.Value, True)

    ListBox3.List = arr1

End Sub

Private Sub zhiwu_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

ListBox4.Visible = True '职务智能提示输入

ListBox4.Clear

On Error Resume Next

Dim arr, arr1, m%, d As New Dictionary

    Set d = CreateObject("scripting.dictionary")

    arr = Range("f2", [f2].End(xlDown))

    For m = 1 To UBound(arr)

        d.Add arr(m, 1), ""

    Next

    arr1 = Filter(d.Keys, zhiwu.Value, True)

    ListBox4.List = arr1

End Sub

Private Sub ListBox2_Click() '姓名列表框2点击事件

xingming = ListBox2.Text

ListBox2.Visible = False

End Sub

Private Sub ListBox3_Click() '籍贯列表框2点击事件

jiguan = ListBox3.Text

ListBox3.Visible = False

End Sub

Private Sub ListBox1_Click() '编号列表框1点击事件

bianhao = ListBox1.Text

ListBox1.Visible = False

End Sub

Private Sub ListBox4_Click() '职务列表框1点击事件

zhiwu = ListBox4.Text

ListBox4.Visible = False

End Sub

Private Sub UserForm_Click() '点击窗体隐藏列表框

ListBox1.Visible = False

ListBox2.Visible = False

ListBox3.Visible = False

ListBox4.Visible = False

End Sub

Private Sub 查询_Click()

 Dim a As Range, b As Range

 Set a = Range("a2", [a2].End(xlDown)).Find(bianhao.Value)

 Set b = Range("b2", [b2].End(xlDown)).Find(xingming.Value)

 If Not a Is Nothing Then

    xingming = a(, 2)

    If lan.Caption = a(, 3) Then lan = True

    If nv.Caption = a(, 3) Then nv = True

    jiguan = a(, 4)

    chusheng = a(, 5)

    zhiwu = a(, 6)

    beizhu = a(, 7)

    Application.Goto a, True

 ElseIf Not b Is Nothing Then

    bianhao = b(, 0)

    If lan.Caption = b(, 2) Then lan = True

    If nv.Caption = b(, 2) Then nv = True

    jiguan = b(, 3)

    chusheng = b(, 4)

    zhiwu = b(, 5)

    beizhu = b(, 6)

    Application.Goto b, True

 Else

    MsgBox "对不起，你查找的资料不存在！"

 End If

End Sub

Private Sub 清空_Click()

Dim con As Control '清空控件中的内容

    For Each con In Me.Controls

        If TypeName(con) = "TextBox" Then con = ""

    Next

End Sub

Private Sub 新增_Click()

ActiveSheet.Unprotect "123"

Dim a As Range, b As Range, arr

Set a = [a65536].End(xlUp)(2)

Set b = Range("a2", [a2].End(xlDown)).Find(bianhao.Value)

If Not b Is Nothing Then

    MsgBox "此编号已被使用"

ElseIf lan = True Then

    arr = Array(bianhao.Text, xingming.Text, lan.Caption, jiguan.Text, _

    chusheng.Text, zhiwu.Text, beizhu.Text)

    a.Resize(, 7) = arr

ElseIf nv = True Then

    arr = Array(bianhao.Text, xingming.Text, nv.Caption, jiguan.Text, _

    chusheng.Text, zhiwu.Text, beizhu.Text)

    a.Resize(, 7) = arr

End If

    With [a:g]

        .Font.Size = 10

        .EntireColumn.AutoFit

        .HorizontalAlignment = xlCenter

    End With

    a.Resize(, 7).Borders.LineStyle = xlContinuous

ActiveSheet.Protect "123", True, True, True

ThisWorkbook.Save

End Sub

Private Sub 修改_Click()

ActiveSheet.Unprotect "123"

Dim a As Range, b As Range, arr

 Set a = Range("a2", [a2].End(xlDown)).Find(bianhao.Value)

 Set b = Range("b2", [b2].End(xlDown)).Find(xingming.Value)

If Not a Is Nothing Then

    If lan = True Then

        arr = Array(bianhao.Text, xingming.Text, lan.Caption, jiguan.Text, _

        chusheng.Text, zhiwu.Text, beizhu.Text)

        a.Resize(, 7) = arr

    ElseIf nv = True Then

        arr = Array(bianhao.Text, xingming.Text, nv.Caption, jiguan.Text, _

        chusheng.Text, zhiwu.Text, beizhu.Text)

        a.Resize(, 7) = arr

    End If

    Application.Goto a, True

ElseIf Not b Is Nothing Then

    If lan = True Then

        arr = Array(bianhao.Text, xingming.Text, lan.Caption, jiguan.Text, _

        chusheng.Text, zhiwu.Text, beizhu.Text)

        b(, 0).Resize(, 7) = arr

    ElseIf nv = True Then

        arr = Array(bianhao.Text, xingming.Text, nv.Caption, jiguan.Text, _

        chusheng.Text, zhiwu.Text, beizhu.Text)

        b(, 0).Resize(, 7) = arr

    End If

    Application.Goto b, True

End If

ActiveSheet.Protect "123", True, True, True

 ThisWorkbook.Save

End Sub