|
|
Sub 字典嵌套及字典多项值存入数组汇总处理()
Dim d As Object, ds As Object, sh As Worksheet, a1, Arr, brr, i&, j&, l&, s, s1, s2
Arr = Sheet1.[a1].CurrentRegion
R_Max = UBound(Arr)
C_Max = UBound(Arr, 2)
Set d = CreateObject("scripting.dictionary") '创建字典对象
For i = 2 To UBound(Arr) '逐列数据
strm = Format(Arr(i, 3), "yyyy-mm")
strd = Format(Arr(i, 3), "yyyy-mm-dd")
If Not d.exists(strm) Then Set d(strm) = CreateObject("scripting.dictionary") '创建该字典对象'建立嵌套字典，第一重字典的键对应的键值为字典
'd(strm)(strd) = Array(arr(i, 4), (d(strm)(strd) & "," & i)) '一级字典对应的项值为二级字典的键值，即二级字典的项值记住行号
' d(strm)(strd) = d(strm)(strd) + arr(i, 4) '一级字典对应的项值为二级字典的键值，而用二级字典的项值来合计
' d(strm)(strd) = Array(1, d(strm)(strd) + 1)
If Not d(strm).exists(strd) Then
s = Arr(i, 4)
s1 = 1
d(strm)(strd) = Array(s1, s) '将字典的各项值放在数组中
Else
s = s + Arr(i, 4)
s1 = s1 + 1
d(strm)(strd) = Array(s1, s)
End If
Next i
a1 = d.keys '一级字典的键值
b1 = d.items ''一级字典对应的项值为二级字典的键值
c1 = b1(0).keys ''一级字典对应的项值为二级字典的键值
c2 = b1(0).items '二级字典的项值
Worksheets("结果").Activate
Cells.ClearContents
For j = 0 To d.Count - 1
Cells(1, j * 4 + 1) = d.keys()(j) '将一级字典关键字写入行标题
Cells(2, j * 4 + 1).Resize(d(d.keys()(j)).Count, 1) = Application.Transpose(d(d.keys()(j)).keys) '将二级字典关键字写入数据表
' Cells(2, j * 3 + 1).Resize(d(d.Keys()(j)).Count, 1) = Application.Transpose(b1(j).Keys) '将二级字典关键字写入数据表
Cells(2, j * 4 + 2).Resize(d(d.keys()(j)).Count, 2) = Application.Transpose(Application.Transpose(d(d.keys()(j)).items))
'Cells(2, j * 3 + 3).Resize(d(d.Keys()(j)).Count, 3) = Application.Transpose(d(d.Keys()(j)).items) '将二级字典项目写入数据表
' Cells(2, 1).Resize(2, 2) = Application.Transpose(d(d.keys()(j)).items) '将二级字典项目写入数据表
' Cells(2, j * 3 + 1).Resize(d(d.Keys()(j)).Count, 2) = WorksheetFunction.Transpose(Array(d(d.Keys()(j)).Keys, d(d.Keys()(j)).items)) '上述过程可以合并为一句代码：
r = Cells(Rows.Count, j * 4 + 1).End(xlUp).Row + 1
Cells(r, j * 4 + 1) = "合计"
Cells(r, j * 4 + 2) = "=SUM(R[-" & r - 2 & "]C:R[-1]C)"
Cells(r, j * 4 + 3) = "=SUM(R[-" & r - 2 & "]C:R[-1]C)"
Next
Set d = Nothing
Worksheets("结果").Activate
'''''''''''''''''''''''''''''
End Sub
Sub 结合字典及数组嵌套法进行拆分处理()
Dim Arr, m%, i%, j%, brr, x
Dim d
Dim s As String, N%, k%, a, b, c As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'On Error Resume Next
ThisWorkbook.Activate
Dim R_Max%, C_Max%
With ThisWorkbook.Worksheets("Sheet1")
Arr = .[a1].CurrentRegion
End With
R_Max = UBound(Arr)
C_Max = UBound(Arr, 2)
'''''''''''''''''''''''''''''''''''''''
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(Arr)
s = Format(Arr(i, 3), "yyyy-mm")
If Len(s) Then d(s) = d(s) & "," & i
Next
a = d.keys
b = d.items
ReDim brr(0 To d.Count - 1) '定义嵌套父数组brr
ReDim x(1 To R_Max, 1 To C_Max) '定义子数组x
For i = 0 To d.Count - 1
brr(i) = x '生成所需大小的嵌套数组
Next
For i = 0 To d.Count - 1
c = Split(Mid(b(i), 2), ",")
N = 0
For j = 0 To UBound(c)
N = N + 1
For k = 2 To C_Max
brr(i)(N, k) = Arr(c(j), k)
Next k
Next j
Next i
''''''判断目录是否存在，不存在则建立目录
Dim sr, fl As String, fso
Set fso = CreateObject("scripting.FileSystemObject")
fl = ThisWorkbook.Path & "\我的文件夹\"
If Dir(fl, vbDirectory) <> "" Then
Set sr = fso.GetFolder(fl)
sr.Delete
End If
If Dir(fl, vbDirectory) = "" Then
MkDir fl
End If
''''判断目录是否存在，不存在则建立目录
'On Error Resume Next
Dim MyFilePath As String, wb As Workbook
MyFilePath = fl & "副本_" & Mid(ThisWorkbook.name, 1, InStrRev(ThisWorkbook.name, ".") - 1) & ".xls"
'Set wb = Workbooks.Add(xlWBATWorksheet)
#If Win64 Then
Set wb = Workbooks.Add
#Else
Set wb = Workbooks.Add(xlWBATWorksheet)
#End If
wb.SaveAs MyFilePath, FileFormat:=xlNormal
With wb
For i = 0 To d.Count - 1
.Sheets.Add before:=wb.Sheets.item(wb.Sheets.Count)
With ActiveSheet
.name = a(i) & "月总明细表"
[a1:f1] = Split("学工号,姓名,操作时间,交易金额,操作描述,交易终端,", ",")
.Range("a2").Resize(N, C_Max).Value = brr(i)
With Cells
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.EntireColumn.AutoFit
End With
End With
Next i
End With
wb.Close True
Set d = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-2-23 19:23
看不明白