Excel VBA para separar texto de algunas celdas y crear múltiples celdas de datos

Question

Me gustaría que alguien sugiriera la codificación en VBA necesaria para convertir estos datos. Básicamente, B2 y B3 habrá varias celdas como allí, incluso con más ";" y números después. La T y la I no cambiarán, pero algunos no siempre tienen T o I, son solo un número.

El resultado final debe ser B12:C37

Básicamente, quiero una lista de números con los datos correspondientes al lado. Entonces, 1T4 debe ser 1,2,3,4 en 4 celdas (en 1 columna), 1T5I2 es 1,3,5 (donde I2 = 2 enteros de diferencia). T y yo no siempre tenemos que estar ahí. Si T está allí, yo no tengo por qué estar allí. Si T está ahí, I siempre está detrás.

Si la celda muestra 25;45;56;79, entonces 25 va a 1 celda, 45 a otra, etc.

Las únicas combinaciones que verá son: 1;1T2;1T5I2. Y los números serán enteros positivos potencialmente hasta 10000.

Podría haber B2 a B20, y los puntos y coma podrían ser miles de ellos.....

Estoy pensando en un bucle para mirar cada carácter y, si es un número, luego hacer una cadena entre los números hasta que se rompa con T, I o; - Sin embargo, estoy estancado.

Imagen de lo que busco en Excel:

Answer 1

Macro3 es un punto y coma múltiple en una celda.
Macro2 es para múltiples entradas de B2 a B20.
Copie y pegue esta macro con la hoja y ejecútela:

Sub Macro3()
'
Dim Txt1, TxtL, Str(), Fruit, Txt As String
Dim x, n, Ff, Tt, Ii, r, i, L, Lx, ix As Integer

r = 12

For x = 2 To 20
Txt1 = Range("B" & x).Value
TxtL = Txt1
Fruit = Range("A" & x).Value
L = Len(Txt1) - Len(Replace(Txt1, ";", ""))
ReDim Str(L)
If Txt1 = "" Then Exit For

For Lx = 0 To L
ix = InStr(1, TxtL, ";")
If ix = 0 Then ix = Len(Txt1) + 1
Str(Lx) = Left(TxtL, ix - 1)
TxtL = Mid(TxtL, ix + 1, Len(Txt1))
Next Lx

For n = 0 To L
Txt = Str(n)
Ff = 0: Tt = 0: Ii = 1
Ff = Val(Txt)
If InStr(1, Txt, "T") > 0 Then Tt = Val(Mid(Txt, InStr(1, Txt, "T") + 1, Len(Txt))) Else Tt = Ff
If InStr(1, Txt, "I") > 0 Then Ii = Val(Mid(Txt, InStr(1, Txt, "I") + 1, Len(Txt))) Else Ii = 1
For i = Ff To Tt Step Ii
Range("D" & r).Value = i
Range("E" & r).Value = Fruit
r = r + 1
Next i
Next n
Next x

MsgBox "done"
End Sub

---

Sub Macro2()
'
Dim Txt1, Str(4), Fruit, Txt As String
Dim x, n, Ff, Tt, Ii, r, i As Integer

r = 12
For x = 2 To 20
Txt1 = Range("B" & x).Value
Fruit = Range("A" & x).Value
If Txt1 = "" Then Exit For
Str(0) = Left(Txt1, InStr(1, Txt1, ";") - 1)
Str(1) = Mid(Txt1, InStr(1, Txt1, ";") + 1, Len(Txt1))

For n = 0 To 1
Txt = Str(n)
Ff = 0: Tt = 0: Ii = 1
Ff = Val(Txt)
If InStr(1, Txt, "T") > 0 Then Tt = Val(Mid(Txt, InStr(1, Txt, "T") + 1, Len(Txt))) Else Tt = Ff
If InStr(1, Txt, "I") > 0 Then Ii = Val(Mid(Txt, InStr(1, Txt, "I") + 1, Len(Txt))) Else Ii = 1
For i = Ff To Tt Step Ii
Range("D" & r).Value = i
Range("E" & r).Value = Fruit
r = r + 1
Next i
Next n
Next x
MsgBox "done"
End Sub

---

Sub Macro1()    
'    
Dim Txt1, Txt2, Str(4), Txt As String    
Dim n, Ff, Tt, Ii, r, i As Integer

Txt1 = Range("B2").Value    
Txt2 = Range("B3").Value    
Str(0) = Left(Txt1, InStr(1, Txt1, ";") - 1)    
Str(1) = Mid(Txt1, InStr(1, Txt1, ";") + 1, Len(Txt1))    
Str(2) = Left(Txt2, InStr(1, Txt2, ";") - 1)    
Str(3) = Mid(Txt2, InStr(1, Txt2, ";") + 1, Len(Txt2))    

r = 12    
For n = 0 To 3    
Txt = Str(n)    
Ff = 0: Tt = 0: Ii = 1    
Ff = Val(Txt)    
If InStr(1, Txt, "T") > 0 Then Tt = Val(Mid(Txt, InStr(1, Txt, "T") + 1, Len(Txt))) Else Tt = Ff    
If InStr(1, Txt, "I") > 0 Then Ii = Val(Mid(Txt, InStr(1, Txt, "I") + 1, Len(Txt))) Else Ii = 1    
For i = Ff To Tt Step Ii    
Range("B" & r).Value = i    
If i >= 1 And i <= 10 Then Range("C" & r).Value = "Apple"    
If i > 10 Then Range("C" & r).Value = "Mango"    
r = r + 1    
Next i
Next n

MsgBox "done"    
End Sub