­ã´£³¡ªL

¦^´_ 3# starry1314

Sub ²Î­p¤£ÄÝ©ó¥k°¼()
Dim A, xD, Arr, j&, Jm%, k%, T$
Set xD = CreateObject("Scripting.Dictionary")
Arr = [F1:Y2]
For j = 1 To UBound(Arr, 2)
    xD(Arr(1, j)) = j: Arr(1, j) = "": Arr(2, j) = ""
Next j

For Each A In Range([A2], [A1].Cells(Rows.Count, 1).End(xlUp)).Value
    T = Mid(A, 3): If T = "" Then GoTo 101
    For j = 1 To Len(T)
        If Val(Mid(T, j, 1) & 1) Then T = Left(T, j - 1): Exit For
    Next
    k = 1: If Right(A, 1) = "V" Then k = 2
    Jm = xD(T)
    If Jm = 0 Then Arr(k, 1) = Val(Arr(k, 1)) + 1: GoTo 101
    Arr(k, Jm) = Val(Arr(k, Jm)) + 1
    Arr(k, 2) = Val(Arr(k, 2)) + 1
101: Next
[F3].Resize(2, UBound(Arr, 2)) = Arr
End Sub

­ã´£³¡ªL

Sub ²Î­p¤£ÄÝ©ó¥k°¼()
Dim A, xD, Arr, j&, Jm%, k%, T$
Set xD = CreateObject("Scripting.Dictionary")
Arr = [F1:Y2]
For j = 1 To UBound(Arr, 2)
    xD(Arr(1, j)) = j: Arr(1, j) = "": Arr(2, j) = ""
Next j

For Each A In Range([A2], [A1].Cells(Rows.Count, 1).End(xlUp)).Value
    T = Mid(A, 3): If T = "" Or xD(A) = 1 Then GoTo 101
    xD(A) = 1
    For j = 1 To Len(T)
        If Val(Mid(T, j, 1) & 1) Then T = Left(T, j - 1): Exit For
    Next
    k = 1: If Right(A, 1) = "V" Then k = 2
    Jm = xD(T)
    If Jm = 0 Then Arr(k, 1) = Val(Arr(k, 1)) + 1: GoTo 101
    Arr(k, Jm) = Val(Arr(k, Jm)) + 1
    Arr(k, 2) = Val(Arr(k, 2)) + 1
101: Next
[F3].Resize(2, UBound(Arr, 2)) = Arr
End Sub