jesscc

ÁÂÁ­ã¤j¡A¯u¬O§Ö¤S·Ç¡A¦ý¬O§Ú¦³2­Ó¤p°ÝÃD¡A¦]¬°"ºØÃþ"©M"½c¼Æ"¤§¶¡ÁÙ¦³¨ä¥LÄæ¦ì¡A¬O§_¯à°÷¥u¦C¥X½c¼Æ´N¦n?¯à¥Î¤½¦¡¼g¥X³o¼Ëªº®ÄªG¶Ü?

­ã´£³¡ªL

Sub TEST()
Dim Arr, xD, i&, j&, A$, B, T$, N&
[E2:F2000].ClearContents
Arr = Range([B6], [A65536].End(xlUp))
Set xD = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
    A = Arr(i, 1):  B = Arr(i, 2)
    If A = "" Or Val(B) = 0 Then GoTo 101
    If xD(A) = 0 Then N = N + 1: xD(A) = N: Arr(N, 1) = A: Arr(N, 2) = 0
    B = Split(B & "-" & B, "-")
    For j = B(0) To B(1)
        T = A & "/" & j:  xD(T) = xD(T) + 1
        If xD(T) = 1 Then Arr(xD(A), 2) = Arr(xD(A), 2) + 1
    Next j
101: Next
If N > 0 Then [E2:F2].Resize(N) = Arr
End Sub