VBAで動作が連続しません

セルの改行で区切られたテキストを分割して最終列まで行いたいのですが、
C2セルは動きますがC3以降連続して動きません。
下記記述のどこがいけないのかご指南いただけませんでしょうか？
よろしくお願いいたします。

Sub 改行を含むセルの値を分割する右()

Dim str
Set str = ActiveCell '対象セルを変数に代入する

With str
Do Until InStr(str, vbLf) = 0 'セルの値の中からVbLfがなくなるまで繰り返す

If .Offset(0, 1).Value <> "" Then '対象セルの右が空白でなければ
.Offset(0, 1).Insert shift:=xlToRight '対象セルの下に空白セルを挿入する
'.Offset(0, 1).EntireRow.Insert shift:=xlToRight ’対象セルの右に空白行を挿入する
End If
.Offset(0, 1).Value = Mid(.Text, InStrRev(.Text, vbLf) + 1)
.Value = Left(.Text, InStrRev(.Text, vbLf) - 1)
Loop
.Offset(1, 0).End(xlToLeft).Select
End With

Set str = Nothing

End Sub

No.1 回答者： ShowMeHow 回答日時： 2021/03/04 11:47

split関数を勉強されたら良いと思います。

この回答へのお礼

勉強になります。
ありがとうございました

お礼日時：2021/03/04 18:12

No.2 ベストアンサー 回答者： fujillin 回答日時： 2021/03/04 12:55

こんにちは

＞C2セルは動きますがC3以降連続して動きません。
ご提示のコードは、行方向には繰り返していないように見えますけれど？

No1様のご指摘のように、Splitを利用するのが簡単だと思います。
以下、ご参考までに。
（上書きしないようB列の値はそのままにして、C列以降に記入するようにしてあります）

Dim rw, s

For rw = 2 To Cells(Rows.Count, 1).End(xlUp).Row
　s = Split(Cells(rw, 2).Text, vbLf)
　Cells(rw, 3).Resize(, UBound(s) - LBound(s) + 1).Value = s
Next rw

この回答へのお礼

動きました。勉強になり助かりました。

お礼日時：2021/03/04 18:11