VBA-字典与用户界面设计+ACCESS系统开发

1，字典：就是一个数组 只有两列

作用：去重复

  使用字典首先得勾选工具中的

然后才可以使用

Sub test2()
Dim dic As New Dictionary
dic.Add "张三", 3000
dic.Add "李四", 2000
dic("李四") = 8000
Range("a10") = dic("李四")
End Sub

循环添加，但是这个方法有个问题，就是如果有重复的key值，程序就会崩溃

Sub test2()
Dim dic As New Dictionary
For i = 2 To 4
    dic.Add Range("d" & i).Value, Range("e" & i).Value
Next

End Sub

这种方式可以进行值得更改，避免因重复更导致程序崩溃

Sub test2()
Dim dic As New Dictionary
dic("张三") = 4000
dic("李四") = 3000
dic("李四") = 8000
Range("a10") = dic("李四")
End Sub

利用上面的方法，进行优化，可以去重复，但李四最后的值是8000

Sub test2()
Dim dic As New Dictionary
For i = 2 To 5
    dic(Range("d" & i).Value) = Range("a" & i).Value
Next

MsgBox dic.Count    '验证
Range("a15:d15") = dic.Keys '验证
End Sub

使用单元格赋值，很明显比较麻烦，因此这里可以使用数组来

Sub test2()
Dim dic As New Dictionary
Dim arr()
arr = Range("d2:e5")
For i = 1 To 4
    dic(arr(i, 1)) = arr(i, 2)
Next

MsgBox dic.Count    '验证
Range("a15:d15") = dic.Key '验证
End Sub

2， 门店销售记录

 工程

Dim arr()
Dim ID As String
Dim DJ As Long
-----------------------------------------------------------------------

Private Sub CommandButton1_Click()
If Me.ListBox1.Value <> "" And Me.ListBox2.Value <> "" And Me.ListBox3.Value <> "" And Me.TextBox1 > 0 Then
    
    Me.ListBox4.AddItem
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 0) = ID
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 1) = Me.ListBox1.Value
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 2) = Me.ListBox2.Value
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 3) = Me.ListBox3.Value
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 4) = Me.TextBox1.Value
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 5) = Me.TextBox1.Value * Me.Label2.Caption
Else
    MsgBox "请正确选择商品"
End If
Me.Label5.Caption = Me.Label5.Caption + Me.TextBox1.Value * Me.Label2.Caption
End Sub
---------------------------------------------------------------------
Private Sub CommandButton2_Click()
For i = 0 To Me.ListBox4.ListCount - 1
    If Me.ListBox4.Selected(i) = True Then
        Me.Label5.Caption = Me.Label5.Caption - Me.ListBox4.List(i, 5)
        Me.ListBox4.RemoveItem i
    End If
Next
End Sub
------------------------------------------------------------------------
Private Sub CommandButton3_Click()
Dim DDID As String
Dim i
If Me.ListBox4.ListCount > 0 Then
    i = Sheet2.Range("a65536").End(xlUp).Row + 1
    DDID = "D" & Format(VBA.Now, "yyyymmddhhmmss")
    For j = 0 To Me.ListBox4.ListCount - 1
        Sheet2.Range("a" & i) = DDID
        Sheet2.Range("b" & i) = Date
        Sheet2.Range("c" & i) = Me.ListBox4.List(j, 0)
        Sheet2.Range("d" & i) = Me.ListBox4.List(j, 4)
        Sheet2.Range("e" & i) = Me.ListBox4.List(j, 5)
        i = i + 1
    Next
    
    MsgBox "结算成功"
    Unload Me
Else
    MsgBox "购物清单为空"
End If
End Sub
-------------------------------------------------------------------
Private Sub ListBox1_Click()
Dim dic
'arr = Sheet1.Range("a2:e" & Sheet1.Range("a65536").End(xlUp).Row)
Set dic = CreateObject("Scripting.Dictionary")
Me.ListBox2.Clear
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value Then
    
        dic(arr(i, 3)) = 1
    End If
Next
Me.ListBox2.List = dic.keys
Me.ListBox3.Clear
Me.Label2.Caption = 0

End Sub
-----------------------------------------------------------------------
Private Sub ListBox2_Click()
Dim dic
Me.ListBox3.Clear
Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value And arr(i, 3) = Me.ListBox2.Value Then
        dic(arr(i, 4)) = 1
    End If
Next
Me.ListBox3.List = dic.keys
Me.Label2.Caption = 0

End Sub
-------------------------------------------------------------------
Private Sub ListBox3_Click()
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value And arr(i, 3) = Me.ListBox2.Value And arr(i, 4) = Me.ListBox3.Value Then
        ID = arr(i, 1)
        DJ = arr(i, 5)
    End If
Next

Me.Label2.Caption = DJ

End Sub
--------------------------------------------------------------------
Private Sub ListBox4_Click()

End Sub
--------------------------------------------------------------------
Private Sub UserForm_Activate()
Dim dic
arr = Sheet1.Range("a2:e" & Sheet1.Range("a65536").End(xlUp).Row)
Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(arr) To UBound(arr)
    dic(arr(i, 2)) = 1
Next
Me.ListBox1.List = dic.keys
End Sub

 

Private Sub CommandButton1_Click()
UserForm1.Show
End Sub

3，ACCESS系统开发

通过上面的销售制作，在每次添加数据后，久而久之，文件会变得很大，且如果收银台有两个，那么必须的有两张表，最后再进行合并数据，那么这就用到了ACCESS

将上面excel版的销售记录更改为access版

1）将产品信息放在access里面

 2）更改下代码，在每次打开excel之前抓取access里面产品信息里的数据

Private Sub Workbook_Open()
Dim conn As New ADODB.Connection
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:datadata.accdb"
Sheet1.Range("a2").CopyFromRecordset conn.Execute("select * from [产品信息]")

conn.Close

End Sub

userform1里面的代码也需要更改，仅更改arr 取值范围就可以了，其余代码和上面相同

Private Sub UserForm_Activate()
Dim dic
arr = Sheet1.Range("b2:f" & Sheet1.Range("a65536").End(xlUp).Row)
Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(arr) To UBound(arr)
    dic(arr(i, 2)) = 1
Next
Me.ListBox1.List = dic.keys
End Sub

3）然后有新的产品直接在access里面添加，在打开excel之后数据被抓取进去

 4）完整版access版销售记录

Private Sub Workbook_Open()
Dim conn As New ADODB.Connection
Sheet1.Range("a2:f1000").ClearContents

conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:datadata.accdb"
Sheet1.Range("a2").CopyFromRecordset conn.Execute("select * from [产品信息]")

conn.Close

End Sub

Dim arr()
Dim ID As String
Dim DJ As Long
-----------------------------------------------------------------------

Private Sub CommandButton1_Click()
If Me.ListBox1.Value <> "" And Me.ListBox2.Value <> "" And Me.ListBox3.Value <> "" And Me.TextBox1 > 0 Then
    
    Me.ListBox4.AddItem
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 0) = ID
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 1) = Me.ListBox1.Value
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 2) = Me.ListBox2.Value
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 3) = Me.ListBox3.Value
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 4) = Me.TextBox1.Value
    Me.ListBox4.List(Me.ListBox4.ListCount - 1, 5) = Me.TextBox1.Value * Me.Label2.Caption
Else
    MsgBox "请正确选择商品"
End If
Me.Label5.Caption = Me.Label5.Caption + Me.TextBox1.Value * Me.Label2.Caption
End Sub
-----------------------------------------------------------------------
Private Sub CommandButton2_Click()
For i = 0 To Me.ListBox4.ListCount - 1
    If Me.ListBox4.Selected(i) = True Then
        Me.Label5.Caption = Me.Label5.Caption - Me.ListBox4.List(i, 5)
        Me.ListBox4.RemoveItem i
    End If
Next
End Sub
-----------------------------------------------------------------------
Private Sub CommandButton3_Click()
Dim DDID As String
Dim conn As New ADODB.Connection
Dim str As String


If Me.ListBox4.ListCount > 0 Then
    DDID = "D" & Format(VBA.Now, "yyyymmddhhmmss")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:datadata.accdb"
    For i = 0 To Me.ListBox4.ListCount - 1
    '    str = "('" & DDID & "','" & Date & "','" & Me.ListBox4.List(0, 0) & "'," & Me.ListBox4.List(0, 4) & "," & Me.ListBox4.List(0, 5) & ")"
        str = "('" & DDID & "','2020/5/7','" & Me.ListBox4.List(i, 0) & "'," & Me.ListBox4.List(i, 4) & "," & Me.ListBox4.List(i, 5) & ")"
        conn.Execute ("insert into [销售记录](订单号,日期,产品编号,数量,金额) values" & str)
    Next
    conn.Close
    MsgBox "结算成功"
    Unload Me
Else
    MsgBox "购物清单为空"
End If
End Sub
-----------------------------------------------------------------------
Private Sub ListBox1_Click()
Dim dic

Set dic = CreateObject("Scripting.Dictionary")
Me.ListBox2.Clear
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value Then
    
        dic(arr(i, 3)) = 1
    End If
Next
Me.ListBox2.List = dic.keys
Me.ListBox3.Clear
Me.Label2.Caption = 0

End Sub
-----------------------------------------------------------------------
Private Sub ListBox2_Click()
Dim dic
Me.ListBox3.Clear
Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value And arr(i, 3) = Me.ListBox2.Value Then
        dic(arr(i, 4)) = 1
    End If
Next
Me.ListBox3.List = dic.keys
Me.Label2.Caption = 0

End Sub
-----------------------------------------------------------------------
Private Sub ListBox3_Click()
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value And arr(i, 3) = Me.ListBox2.Value And arr(i, 4) = Me.ListBox3.Value Then
        ID = arr(i, 1)
        DJ = arr(i, 5)
    End If
Next

Me.Label2.Caption = DJ

End Sub
-----------------------------------------------------------------------


Private Sub UserForm_Activate()
Dim dic
arr = Sheet1.Range("b2:f" & Sheet1.Range("a65536").End(xlUp).Row)
Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(arr) To UBound(arr)
    dic(arr(i, 2)) = 1
Next
Me.ListBox1.List = dic.keys
End Sub