Excel VBA zum Aufteilen von Text aus einigen Zellen und Erstellen mehrerer Datenzellen

Question

Ich hätte gern, dass mir jemand den VBA-Code vorschlägt, der zum Konvertieren dieser Daten erforderlich ist. Im Wesentlichen wird es in B2 und B3 mehrere Zellen wie dort geben, sogar mit mehr ";" und Zahlen dahinter. Das T und das I ändern sich nicht, aber einige haben nicht immer T oder I, sondern nur eine einzelne Zahl.

Die endgültige Ausgabe muss B12:C37 sein

Ich möchte im Wesentlichen eine Liste von Zahlen mit den entsprechenden Daten daneben. 1T4 sollte also 1,2,3,4 in 4 Zellen (in 1 Spalte) sein, 1T5I2 ist 1,3,5 (wobei I2 = 2 Ganzzahlen auseinander). T und I müssen nicht immer da sein. Wenn T da ist, muss I nicht da sein. Wenn T da ist, folgt immer I.

Zeigt die Zelle beispielsweise 25;45;56;79, dann kommt 25 in eine Zelle, 45 in eine andere usw.

Die einzigen Kombinationen, die Sie sehen werden, sind: 1;1T2;1T5I2. Und die Zahlen werden positive Ganzzahlen sein, möglicherweise bis zu 10000.

Es könnte B2 bis B20 geben und es könnten Tausende von Semikolons sein...

Ich denke an eine Schleife, die sich jedes Zeichen ansieht und, wenn es eine Zahl ist, dann eine Zeichenfolge zwischen den Zahlen erstellt, bis sie durch ein T, I oder ; unterbrochen wird. - Allerdings stecke ich fest.

Bild von dem, was ich suche, in Excel:

Answer 1

Makro3 besteht aus mehreren Semikolons in einer Zelle.
Makro2 dient für mehrere Eingaben von B2 bis B20.
Kopieren Sie dieses Makro, fügen Sie es in das Blatt ein und führen Sie es aus:

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