いくつかのセルからテキストを分離し、複数のデータセルを作成するための Excel VBA

Question

このデータを変換するために必要な VBA のコーディングを誰かに提案してもらいたいです。基本的に、B2 と B3 には、そこにのような複数のセルがあり、さらに「;」と数字が続きます。T と I は変わりませんが、T または I が常にあるわけではなく、単一の数字である場合もあります。

最終出力はB12:C37である必要があります

基本的に、対応するデータが横にある数字のリストが必要です。したがって、1T4 は 4 つのセル (1 列) で 1、2、3、4 になり、1T5I2 は 1、3、5 (I2 は 2 つの整数が離れている) になります。T と I は常にそこにある必要はありません。T がある場合、I はそこにある必要はありません。T がある場合、I は常に後にあります。

セルに 25;45;56;79 と表示されている場合、25 が 1 つのセルに入り、45 が別のセルに入ります。

表示される組み合わせは、1;1T2;1T5I2 のみです。数字は、最大 10000 までの正の整数になります。

B2 から B20 まであり、セミコロンは 1000 個程度になることもあります.....

各文字を調べて、数字の場合は、T、I、または; で区切られるまで数字の間に文字列を作成するループを考えていますが、行き詰まっています。

Excel で私が求めているもののイメージ:

Answer 1

マクロ 3 は 1 つのセルに複数のセミコロンを配置します
。マクロ 2 は B2 から B20 までの複数の入力用です。
このマクロをコピーしてシートに貼り付け、実行します。

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