LF(改行)でセルの内容を分割する：Excel VBA

Tweet

LF(改行)でセルの内容を分割する：Excel VBA

以下に示すように，Excelの１つのセルに複数行のデータが書き込まれている際に，改行で区切って各々別のセルとなるように分割するマクロ(VBA)です。

このコードではこちらの「ステータスバーの更新頻度を下げて処理速度を向上させる：Excel VBA」を使用しています。

' 参照設定 mscorlib
' LF(改行)でセルの内容を分割する
' src: コピー元のRange
' dst: コピー先のRange(先頭セルのみで良い)
' add_row_number: 当初の行番号が分かるように，先頭列へコピー元の行番号を付加します。
' skip: 改行分割処理をスキップする（つまり単純コピーになる）列番号を昇順でVariant型の配列で渡す
Sub SplitLF(src As Range, dst As Range, _
    Optional add_row_number As Boolean = True, _
    Optional skip As Variant)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim n_col As Long
    Dim n_row As Long
    n_col = src.Columns.Count
    n_row = src.Rows.Count
 
    ' スキップ配列処理初期化
    Dim skip_count As Long
    Dim skip_array_it As Long ' イテレータ
    If IsMissing(skip) Then
        skip_count = -1
        skip_array_it = 999
    Else
        skip_count = UBound(skip)
        skip_array_it = LBound(skip)
        If add_row_number Then
            For i = LBound(skip) To UBound(skip)
                skip(i) = skip(i) + 1
            Next
        End If
    End If
 
    Dim a As New ArrayList
 
    ' 行番号追記処理初期化
    If add_row_number Then
        n_col = n_col + 1
    End If
 
    ' セルの内容をArrayListへコピー
    Dim data As Variant
    data = src.Value
    For i = LBound(data, 1) To UBound(data, 1)
        Dim b() As String
        ReDim b(1 To n_col)
        If add_row_number Then
            b(1) = src.Row + i - 1 ' 行番号代入
            For j = 1 To n_col - 1
                b(j + 1) = data(i, j)
            Next
        Else
            For j = 1 To n_col
                b(j) = data(i, j)
            Next
        End If
        a.Add b
    Next
    ' ArrayList上で改行分割処理
    For j = 1 To n_col
        If skip_array_it <= skip_count Then
            If skip(skip_array_it) = j Then
                skip_array_it = skip_array_it + 1
                StatusBarUpdate "列" & j & "/" & n_col & "-> skip"
            Else
                i = 0
                Do While i < a.Count
                    StatusBarUpdate "列" & j & "/" & n_col & "->" & i & "/" & a.Count
                    ' a1 へ 1行格納
                    Dim a1 As Variant
                    a1 = a.Item(i)
                    If Len(a.Item(i)(j)) > 0 Then
                        ' j列目の文字を改行区切りでSplit
                        Dim str() As String
                        str = Split(a1(j), vbLf)
                        If UBound(str) > LBound(str) Then
                            Dim a2 As Variant
                            ' 増える要素分だけArrayList.Insert
                            For k = 1 To UBound(str) - LBound(str)
                                a2 = a1
                                a2(j) = str(k)
                                a.Insert i + k, a2 ' i+k番目にa1のj列目を改行区切りで分割した配列のk番目に置換した配列データを挿入
                            Next
                            ' 元の要素の置換
                            a2 = a1
                            a2(j) = str(0)
                            a.Item(i) = a2
                        End If
                        ' 増やした要素数+1行進める
                        i = i + UBound(str) - LBound(str) + 1
                    Else
                        i = i + 1
                    End If
                Loop
            End If
        End If
    Next
    Application.StatusBar = False
    ' 書き込み先へ入力
    For i = 0 To a.Count - 1
        dst.Cells(i + 1, 1).Resize(, n_col) = a.Item(i)
    Next
End Sub

使用例

Sub TEST()
    Dim src_ws As Worksheet
    Dim src_range As Range
    Set src_ws = Sheets("Sheet1")
    src_ws.Activate
    With src_ws.Range("A2").CurrentRegion
        Set src_range = src_ws.Range(src_ws.Range("A3"), .Cells(.Rows.Count - 2, 18))
    End With
    Dim ws As Worksheet
    Set ws = Sheets.Add(After:=src_ws)
    Call SplitLF(src_range, ws.Range("A3"), skip:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 18))
End Sub