Excel マクロ VBA 毎回範囲が変わるセル内改行を分割したい

はじめまして。
ＥｘｃｅｌのＶＢＡ初心者です。類似の質問等も確認しましたが解決できなかったので質問させてください。

A列は固定、行数は毎回変動する範囲の文字列を改行ごとに分割するVBAをご教授いただきたいです。

セル内には空白行、範囲の途中で空白セルもあることがあります。
分割が終わったら、分割前のデータは不要なので削除したいです。

どうぞよろしくお願いいたします。

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2020/06/15 11:57

こんにちは、

一例です。
標準モジュールで

Sub Sample()
　 Dim i As Long, j As Long, n As Long
　 Dim tmp, arrStr()
　 For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
　　 If Cells(i, "A") <> "" Then
　　　　tmp = Split(Cells(i, "A"), vbLf)
　　　　For j = 0 To UBound(tmp)
　　　　　 ReDim Preserve arrStr(n)
　　　　　 arrStr(n) = tmp(j)
　　　　　 n = n + 1
　　　　Next
　　 Else
　　　　n = n + 1
　　 End If
　 Next
　 'B列に書き出しています。　変更してくださいね
　 Cells(1, "B").Resize(n).Value = Application.Transpose(arrStr)
End Sub

この回答へのお礼

ありがとうございます。希望する通りの処理になりました！
シンプルで初心者にもわかりやすくとても勉強になったので、こちらをベストアンサーに選ばせていただきました。

お礼日時：2020/06/15 17:53

No.4 回答者： fujillin 回答日時： 2020/06/15 14:55

こんにちは

すでに回答は出ていますので、ご参考までに。

Sub Sample()
Dim r As Range, s
Set r = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
s = Split(Join(Application.Transpose(r.Value), vbLf), vbLf)

'A列に上書きする場合はB1→A1に
Range("B1").Resize(UBound(s) + 1) = Application.Transpose(s)
End Sub

この回答へのお礼

ありがとうございます。Split構文勉強になります！
参考にさせていただきます。

お礼日時：2020/06/15 17:56

No.2 回答者： rabbit_9999 回答日時： 2020/06/15 11:31

すみません、motoSheet、sakiSheet、i　の変数宣言が抜けてました。

Sub Macro1()

Dim motoSheet As Worksheet
Dim sakiSheet As Worksheet

Set motoSheet = Worksheets("Sheet1")
Set sakiSheet = Worksheets("Sheet2")

Dim motoRow As Integer
Dim sakiRow As Integer
Dim workStr As String
Dim workArray() As String

Dim checkRow As Integer
Dim i As Integer

motoRow = 1
sakiRow = 1
checkRow = 0

Do
workStr = motoSheet.Range("A" & motoRow).Value


If workStr <> "" Then
workArray = Split(workStr, vbLf) '改行文字で分割
For i = 0 To UBound(workArray)
sakiSheet.Range("A" & sakiRow).Value = workArray(i)
sakiRow = sakiRow + 1
Next i

Else
If checkRow > 10 Then '空白が10件続いたら終了
Exit Do
End If
checkRow = checkRow + 1

sakiRow = sakiRow + 1 '何も出力しないで次に移動

End If

motoRow = motoRow + 1

Loop

'後処理
Set sakiSheet = Nothing
Set motoSheet = Nothing

End Sub

この回答へのお礼

ありがとうございます。
VBAはいろいろな処理の仕方があって勉強になります！
他の方の回答含め参考にさせていただきます。

お礼日時：2020/06/15 17:58

No.1 回答者： rabbit_9999 回答日時： 2020/06/15 11:27

こんな感じでしょうか。

Sub Macro1()

Set motoSheet = Worksheets("Sheet1")
Set sakiSheet = Worksheets("Sheet2")

Dim motoRow As Integer
Dim sakiRow As Integer
Dim workStr As String
Dim workArray() As String

Dim checkRow As Integer

motoRow = 1
sakiRow = 1
checkRow = 0

Do
workStr = motoSheet.Range("A" & motoRow).Value


If workStr <> "" Then
workArray = Split(workStr, vbLf) '改行文字で分割
For i = 0 To UBound(workArray)
sakiSheet.Range("A" & sakiRow).Value = workArray(i)
sakiRow = sakiRow + 1
Next i

Else
If checkRow > 10 Then '空白が10件続いたら終了
Exit Do
End If
checkRow = checkRow + 1

sakiRow = sakiRow + 1 '何も出力しないで次に移動

End If

motoRow = motoRow + 1

Loop

'後処理
Set sakiSheet = Nothing
Set motoSheet = Nothing

End Sub

とりあえず、別シートに出力するようにしています。
完了後に元シートが不要だったら、最後に「Sheet1」の削除をしてください。