LF(改行)でセルの内容を分割する:Excel VBA
以下に示すように,Excelの1つのセルに複数行のデータが書き込まれている際に,改行で区切って各々別のセルとなるように分割するマクロ(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
0件のコメント