修改代码

ddz79101

老师，希望提前各表制定列，有代码，但未成。请老师帮忙修改。谢谢！

quqiyuan

本来想在你代码上修改，无奈你的思路跟我的思路不一样，无奈重写了大部分，仅供参考。。。

quqiyuan

代码如下。。。
Sub 月汇()
  Dim r%, i%
  Dim Arr, brr, bt()
  Dim ws As Worksheet
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  bt = Array("1月", "2月", "3月")
  For k = LBound(bt) To UBound(bt)
    With Worksheets(bt(k))
      r = .Cells(.Rows.Count, 1).End(xlUp).Row
      c = .Cells(4, .Columns.Count).End(xlToLeft).Column
      Arr = .Range("a1").Resize(r, c)
      For j = 1 To UBound(Arr, 2)
        If Arr(4, j) = "个人1" Then
          Exit For
        End If
      Next
      If j <= UBound(Arr, 2) Then
        For i = 5 To UBound(Arr)
          s = Arr(i, 2)
          If Not d.exists(s) Then
            Set d(s) = CreateObject("scripting.dictionary")
            d(s)(bt(k)) = Arr(i, j)
          Else
            d(s)(bt(k)) = d(s)(bt(k)) + Arr(i, j)
          End If
        Next
      End If
    End With
  Next
  ReDim brr(1 To d.Count + 1, 1 To UBound(bt) + 3)
  n = 0
  For Each k In d.keys
    n = n + 1
    brr(n, 1) = k
    brr(n, UBound(brr, 2)) = "=sum(rc[-1]:rc[" & -UBound(bt) - 1 & "])"
    For Each kk In d(k).keys
       x = Application.Match(kk, bt, 0) + 1
        brr(n, x) = d(k)(kk)
    Next
  Next
  n = n + 1
  brr(n, 1) = "合计"
  For j = 2 To UBound(brr, 2)
    brr(n, j) = "=sum(r[-1]c:r[" & -n + 1 & "]c)"
  Next
  With Worksheets("汇")
    .Cells.Clear
    .Range("a1") = "对方户名"
    .Range("b1").Resize(1, UBound(bt) + 1) = bt
    .Cells(1, UBound(bt) + 3) = "年支出"
    .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    .[a1].CurrentRegion.Borders.LineStyle = xlContinuous
    With .Range("a:a,1:1")
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
    End With
  Set d = Nothing
  End With
  Beep
End Sub

醉眼看尘世

无聊，弄着玩。。。。

ddz79101

quqiyuan 发表于 2024-9-26 21:58
本来想在你代码上修改，无奈你的思路跟我的思路不一样，无奈重写了大部分，仅供参考。。。

谢谢老师！代码成功

ddz79101

醉眼看尘世 发表于 2024-9-26 22:10
无聊，弄着玩。。。。

谢谢老师！代码成功