Andy2483

¦^´_ 5# c_c_lai


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

°õ¦æ«e:

¤U¸ü (112.51 KB)

2023-4-17 11:50

°õ¦æµ²ªG:

¤U¸ü (145.6 KB)

2023-4-17 11:50

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 100, 1 To 7), Y, R1&, R2&, N&, i&, j&, T(4)
Dim xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([D1], [A1].End(xlDown)): Brr = xR
For i = 2 To UBound(Brr)
   For j = 1 To 4: T(j) = Brr(i, j): Next
   If i = 2 Then
      R1 = 1: R2 = 1
      For j = 1 To 4: Crr(1, j) = Brr(1, j): Next
      For j = 5 To 7: Crr(1, j) = Brr(1, j - 3): Next
   End If
   T(0) = "­Ü«~|" & T(2) & "|" & T(3)
   If Y(T(0)) = "" Then
      R2 = R2 + 1
      Y(T(0)) = R2
      For j = 5 To 7: Crr(R2, j) = T(j - 3): Next
      Else
         N = Y(T(0)): Crr(N, 7) = Crr(N, 7) + T(4)
   End If
   T(0) = "¤é|" & T(1) & "|" & T(0)
   If Y(T(0)) = "" Then
      R1 = R1 + 1: Y(T(0)) = R1
      For j = 1 To 4: Crr(R1, j) = T(j): Next
      Else
         N = Y(T(0)): Crr(N, 4) = Crr(N, 4) + T(4)
   End If
Next
With Rows(UBound(Brr) + 2 & ":65536")
   .Clear
   With .Item(1).Resize(R1 + 1, 7)
      .Value = Crr
      With Intersect(.Cells, [A:D])
         .Sort KEY1:=.Item(1), Order1:=1, _
         Key2:=.Item(2), Order2:=1, _
         Key3:=.Item(3), Order2:=1, Header:=1
      End With
      With Intersect(.Cells, [E:G])
         .Sort KEY1:=.Item(1), Order1:=1, _
         Key2:=.Item(2), Order2:=1, Header:=1
      End With
   End With
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub