Andy2483

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

°õ¦æ«e:

¤U¸ü (138.28 KB)

2023-5-17 10:18

°õ¦æµ²ªG:

¤U¸ü (166.33 KB)

2023-5-17 10:18

Option Explicit
Sub TEST()
Dim Brr, Crr, Q, R&, C&, i&, j&, N&, S$, T$, T1$, T2$, P$, K%, K1%, M&
Brr = Range([C1], Cells(Rows.Count, "A").End(3))
ReDim Crr(1 To 1000, 1 To UBound(Brr))
For i = 1 To UBound(Brr)
   T = Split(Brr(i, 3) & " ", " ")(0): R = 0
   R = R + 1: C = C + 1
   Crr(R, C) = Brr(i, 1) & "-" & Brr(i, 2)
   For Each Q In Split(T, ",")
      P = StrReverse(Q)
      K = InStr(P, "~") - 1
      S = StrReverse(Mid(Val(1 & Mid(P, K + 2)), 2))
      K1 = Len(S)
      If K > -1 Then
         T1 = Split(Q, "~")(0): T2 = Split(Q, "~")(1)
         N = Val(Right(T2, K)) - Val(Right(T1, K))
         For j = 0 To N
            R = R + 1: Crr(R, C) = Mid(StrReverse(T1), K1 + 1) & S + j
         Next
         Else
            R = R + 1: Crr(R, C) = Q
      End If
   Next
   If M < R Then M = R
Next
[H:K].ClearContents
[H1].Resize(M, C) = Crr
Erase Brr, Crr
End Sub