常见字典应用方法及重载

'DictionaryMethodMulOverload
'常见字典应用方法及重载
'subtotal 分类汇总
Function subTotal(arr As Variant)
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 5)) Then Set d(arr(i, 5)) = CreateObject("scripting.dictionary")
If Not d(arr(i, 5)).exists(arr(i, 6)) Then
d(arr(i, 5))(arr(i, 6)) = Array(arr(i, 3), arr(i, 4))
Else
k = d(arr(i, 5))(arr(i, 6))
k(0) = k(0) + arr(i, 3)
k(1) = k(1) + arr(i, 4)
d(arr(i, 5))(arr(i, 6)) = k
End If
Next
End Function

 

Sub 一键制作透视表式统计表9()
Dim r%, i%, arr, brr, d As Object, j&
Application.DisplayAlerts = False
pp = Split(ActiveWorkbook.Name, ".")(0)
Set d = CreateObject("scripting.dictionary")
With Worksheets(1)
r = .Cells(Rows.Count, 1).End(xlUp).Row
brr = .Range("a2:w" & r)
.Range("a1:w" & r).Sort key1:=.Range("h1"), order1:=xlAscending, key2:=.Range("b1"), _
order2:=xlAscending, key3:=.Range("c1"), order3:=xlAscending, Header:=xlYes
arr = .Range("a2:w" & r)
.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
For i = 1 To UBound(arr)
If arr(i, 2) <> "综合组织" Then
If Len(arr(i, 2)) Then
If Not d.exists(arr(i, 8)) Then Set d(arr(i, 8)) = CreateObject("scripting.dictionary")
If Not d(arr(i, 8)).exists(arr(i, 2)) Then Set d(arr(i, 8))(arr(i, 2)) = CreateObject("scripting.dictionary")
'd(arr(i, 8))(arr(i, 2))(arr(i, 3)) = d(arr(i, 8))(arr(i, 2))(arr(i, 3)) + arr(i, 18)
'======================================================
'20170915修订
If Not d(arr(i, 8))(arr(i, 2)).exists(arr(i, 3)) Then
d(arr(i, 8))(arr(i, 2))(arr(i, 3)) = Array(arr(i, 18), arr(i, 13))
Else
k = d(arr(i, 8))(arr(i, 2))(arr(i, 3))
k(0) = k(0) + arr(i, 18)
k(1) = k(1) & "/" & arr(i, 13) '历次进价串联
d(arr(i, 8))(arr(i, 2))(arr(i, 3)) = k
End If
'======================================================
End If
End If
Next i
End With
For j = Sheets.Count To 2 Step -1: Sheets(j).Delete: Next j
kk = d.keys
For i = 0 To UBound(kk) - 1
p = i
For j = i + 1 To UBound(kk)
If Val(kk(p)) > Val(kk(j)) Then p = j
Next j
If p <> i Then
temp = kk(i): kk(i) = kk(p): kk(p) = temp
End If
Next i
For i = 0 To UBound(kk)
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = kk(i): .Range("a1") = "仓库名称": .Range("b1") = kk(i): .Range("c1") = pp
.Range("a2:d2") = Array("中文型号", "英文型号", "期间结存数量", "进货单价")
For Each bb In d(kk(i)).keys
r = .Cells(Rows.Count, 2).End(xlUp).Row + 1
.Cells(r, 1) = bb
'.Cells(r, 2).Resize(d(kk(i))(bb).Count, 2) = Application.Transpose(Array(d(kk(i))(bb).keys, d(kk(i))(bb).items))
'===============================
'20170915修订
.Cells(r, 2).Resize(d(kk(i))(bb).Count) = Application.Transpose(d(kk(i))(bb).keys)
.Cells(r, 3).Resize(d(kk(i))(bb).Count, 2) = Application.Transpose(Application.Transpose(d(kk(i))(bb).items))
'===============================
Next bb
r = .Cells(Rows.Count, 2).End(3).Row
.Range("a2:d" & r).Borders.LineStyle = 1
.Columns("a:d").AutoFit
End With
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub 苏宁销售数量和销售金额匹配()
Application.ScreenUpdating = False
If MsgBox("请确保销售数量表和销售金额表已完成合并，然后选择当月销售金额表所在的路径。", vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then
GoTo 100
Else
Exit Sub
End If
100:
' StartDate = InputBox("请输入开始日期：", "日期")
' StartDate = InputBox("请输入日期：")
' DateStr = Application.InputBox("请指定一个日期：", "日期", Date, , , , , 2)
dateStr = InputBox(prompt:="请输入开始日期：")
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
If .Show Then p = .SelectedItems(1) Else: Exit Sub
End With
Set d = CreateObject("scripting.dictionary")
With GetObject(p)
arr = .Sheets("合并结果").[a1].CurrentRegion
.Close False
End With
For x = 2 To UBound(arr)
If Val(arr(x, 13)) > dateStr Then
s = arr(x, 10) & "," & arr(x, 16)
If Not d.exists(s) Then
d(s) = Array(arr(x, 17), arr(x, 18))
Else
k = d(s)
k(0) = k(0) + arr(x, 17)
k(1) = k(1) + arr(x, 18)
d(s) = k
End If
End If
Next x
a = d.keys: b = d.items
Set ws = ActiveSheet
With ws
brr = .Range("a1").CurrentRegion
c = UBound(brr, 2) + 1
For y = 2 To UBound(brr)
ss = brr(y, 2) & "," & brr(y, 3)
If d.exists(ss) Then
Cells(y, c).Resize(1, 2) = d(ss)
Cells(1, c).Resize(1, 2) = Array("匹配数量", "匹配金额")
End If
Next y
End With
Application.ScreenUpdating = True
End Sub

Function 获取养老保险数据(arrEndowment)
Dim dicEndowment As Object '养老保险
Set dicEndowment = CreateObject("scripting.dictionary")
Dim strPath As New 手动选择文件路径
If MsgBox("下面请选择[养老_应缴明细]!", vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then GoTo 10000 Else Exit Function
10000:
myPath = strPath.手动选择获取指定文件路径
If Len(myPath) = 0 Then MsgBox "您未选择[养老_应缴明细]文件!": Exit Function
Workbooks.OpenText (myPath)
With ActiveWorkbook.ActiveSheet
arr = .UsedRange
ActiveWorkbook.Close
For i = 2 To UBound(arr)
If Not dicEndowment.exists(arr(i, 2)) Then
dicEndowment(arr(i, 2)) = Array(arr(i, 9), arr(i, 12))
Else
k = dicEndowment(arr(i, 2))
k(0) = k(0) + arr(i, 9) '单位缴纳
k(1) = k(1) + arr(i, 12) '个人缴纳
dicEndowment(arr(i, 2)) = k
End If
Next
End With
For x = 3 To UBound(arrEndowment)
If dicEndowment.exists(arrEndowment(x, 2)) Then
s = dicEndowment(arrEndowment(x, 2))
arrEndowment(x, 4) = (s(0))
arrEndowment(x, 5) = (s(1))
End If
Next
获取养老保险数据 = arrEndowment
End Function

Sub InsertRow() '如果单号不同 则插入行
Set d = CreateObject("scripting.dictionary")
With Sheets(zw_ZWMB)
arr = .Range("a1").CurrentRegion
For x = 2 To UBound(arr)
d(arr(x, 21)) = x
Next

t = d.items
For i = UBound(t) To 0 Step -1
.Rows(t(i) + 1).Insert
Next
End With

Sub test()
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For x = 2 To UBound(arr)
For y = 3 To UBound(arr, 2)
s = arr(x, 1) & "+" & arr(x, 2) & "+" & arr(1, y)
d(s) = arr(x, y)
Next
Next
t = d.items
For x = 11 To 43
For y = 3 To 8
s1 = Cells(x, 1).Value & "+" & Cells(10, y).Value & "+" & Cells(x, 2).Value
Cells(x, y) = d(s1)
Next
Next
End Sub