| ©«¤l2843 ¥DÃD10 ºëµØ0 ¿n¤À2899 ÂI¦W0  §@·~¨t²Î¡e²¤¡f ³nÅ骩¥»¡e²¤¡f ¾\ŪÅv100 ©Ê§O¨k ¨Ó¦Û¡e²¤¡f µù¥U®É¶¡2013-5-13 ³Ì«áµn¿ý2025-10-18 
 | 
                
| ¦³ÂI½ÆÂø, ¦Û¦æ°Ñ°u~~ 
 
 ½Æ»s¥N½XSub TEST()
Dim Arr, xD(3), d1, d2, i&, j&, k%, U%, Ur, Srr, xS As Worksheet
For j = 0 To 3: Set xD(j) = CreateObject("Scripting.Dictionary"): Next j
Arr = [L2:M30]
For j = 1 To 2: For i = 1 To UBound(Arr)
    If Arr(i, j) <> "" Then xD(0)(Arr(i, j)) = j
Next: Next
'--------------------------------
Arr = Range([J1], Cells(Rows.Count, 1).End(xlUp))
For i = 2 To UBound(Arr)
    d1 = Arr(i, 3): d2 = Arr(i, 4)
    If IsDate(d1) * IsDate(d2) = 0 Then GoTo 101
    U = xD(0)(Arr(i, 2)) + 1
    For j = d1 To d2 - 1
        Ur = xD(U)(j)
        If Not IsArray(Ur) Then Ur = Array(CDate(j), 0, 0, 0, 0, 0, 0)
        For k = 5 To 10: Ur(k - 4) = Ur(k - 4) + Arr(i, k): Next k
        xD(U)(j) = Ur
    Next j
101: Next i
'--------------------------------
Srr = Array("", "¤@¯ë", "¯S®í1", "¯S®í2")
For k = 1 To 3
    With Sheets(Srr(k))
         .UsedRange.Offset(1, 0).EntireRow.Delete
         U = xD(k).Count: If U = 0 Then GoTo 102
         With .[B2:H2].Resize(U)
              .Value = Application.Transpose(Application.Transpose(xD(k).items))
              .Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
         End With
    End With
102: Next k
End Sub
 
  Xl0000054.rar (21.99 KB) 
 
 ==============================
 | 
 |