结合字典及数组嵌套法进行拆分处理

daly3721

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

jiangxiaoyun

看不明白

熊文来

你这是成品呢？还是说有问题 需要大家帮忙呢？