Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð
°õ¦æ«e:

¤U¸ü (163.45 KB)

2024-1-24 08:53

°õ¦æµ²ªG:

¤U¸ü (178.05 KB)

2024-1-24 08:54

Option Explicit
Sub TEST()
Dim Arr, Brr, Crr(8, 100), A%, Z, B%, V%, i&, C%, T2$, T3$, T4$, T6$, T9$
ActiveSheet.UsedRange.EntireColumn.Offset(, 17).Delete
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([I7], [A65536].End(3))
Crr(0, 0) = Brr(1, 2) & " \ " & Brr(1, 4)
For i = 2 To 8: Crr(i - 1, 0) = Format(i, "DDD"): Z(Crr(i - 1, 0)) = i - 1: Next
Crr(8, 0) = "TOTAL": Arr = Crr
For i = 2 To UBound(Brr)
   T2 = Format(Brr(i, 1), "DDD"): T4 = Brr(i, 4): T6 = Brr(i, 6): T3 = Brr(i, 3): T9 = Brr(i, 9)
   A = Z(T2): B = Z(T4): V = Z(T2 & T6 & T4)
   If B = 0 Then C = C + 1: B = C: Z(Brr(i, 4)) = B: Arr(0, C) = Brr(i, 4): Crr(0, C) = Brr(i, 4)
   If Z(T2 & T3 & T4) = 0 Then Z(T2 & T3 & T4) = 1: Crr(A, B) = Crr(A, B) + 1
   If V = 0 Then V = Val(T9): Z(T2 & T6 & T4) = V: Arr(A, B) = Arr(A, B) + V: GoTo i01
   If Z(T2 & T6 & T4) < Val(T9) Then
      Arr(A, B) = Arr(A, B) - Z(T2 & T6 & T4) + Val(T9): Z(T2 & T6 & T4) = Val(T9)
   End If
i01: Next
[R6] = "²Î­p²Õ§Oµ§¼Æ"
With [R7].Resize(9, C + 1)
   .Value = Crr: .SpecialCells(4) = 0: .Borders.LineStyle = 1: .EntireColumn.HorizontalAlignment = xlCenter
   .Offset(, 1).Sort KEY1:=.Item(1), Order1:=1, Header:=1, Orientation:=2
   .Item(9, 2).Resize(, C) = "=SUM(" & Intersect(.Columns(2), [8:14]).Address(0, 0) & ")"
End With
[R17] = "­pºâ¼Æ¶q"
With [R18].Resize(9, C + 1)
   .Value = Arr: .SpecialCells(4) = 0: .Borders.LineStyle = 1: .Columns(1).EntireColumn.AutoFit
   .Offset(, 1).Sort KEY1:=.Item(1), Order1:=1, Header:=1, Orientation:=2
   .Item(9, 2).Resize(, C) = "=SUM(" & Intersect(.Columns(2), [19:25]).Address(0, 0) & ")"
End With
End Sub