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

Question

はじめまして。
ＥｘｃｅｌのＶＢＡ初心者です。類似の質問等も確認しましたが解決できなかったので質問させてください。

A列は固定、行数は毎回変動する範囲の文字列を改行ごとに分割するVBAをご教授いただきたいです。

セル内には空白行、範囲の途中で空白セルもあることがあります。
分割が終わったら、分割前のデータは不要なので削除したいです。

どうぞよろしくお願いいたします。

Qchan1962 · Accepted Answer

こんにちは、
一例です。
標準モジュールで

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

fujillin · Answer

こんにちは

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

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

rabbit_9999 · Answer

すみません、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

rabbit_9999 · Answer

こんな感じでしょうか。

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」の削除をしてください。

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

こんにちは、

こんにちは

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

こんな感じでしょうか。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

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