セル内で改行された文字列をセル分割したい

質問

以下のような一セル内で改行された文字列を改行ごとに分割して別シートへコピーしたいと考えています。
（以下は山田さんのレコード一行を記載しましたが下のセルに担当者のレコードが同様に続きます。）

　　　Ａ　　　　　　　　　Ｂ　　　　　　　　　　　Ｃ　　　　　　　　　　Ｄ
　----------+---------------+------------+---------------+　
　担当者　　　　　　日付　　　　　　　　　履歴　　　　　　　　更新日
　----------+---------------+------------+---------------+
　山田　　　　　　　2001/01/01　　　　札幌支店　　　　2005/01/01
　　　　　　　　　　　2002/01/01　　　　福岡支店　　　　2005/04/01
　　　　　　　　　　　2003/04/01　　　　東京支店　　　　2005/04/01
　----------+---------------+------------+---------------+

上記を別シートへ以下のようにセル内容を分割してコピーしたいのです。
　　　Ａ　　　　　　　　　Ｂ　　　　　　　　　　　　Ｃ　　　　　　　　　　　Ｄ
　----------+---------------+------------+---------------+
　　担当者　　　　　日付　　　　　　　　　履歴　　　　　　　更新日
　----------+---------------+------------+---------------+
　　　山田　　　　　2001/01/01　　　　札幌支店　　　　　2005/01/01
　----------+---------------+------------+---------------+
　　　山田　　　　　2002/01/01　　　　福岡支店　　　　　2005/04/01
　----------+---------------+------------+---------------+
　　　山田　　　　　2003/04/01　　　　東京支店　　　　　2005/04/01
　----------+---------------+------------+---------------+

当方Ｅｘｃｅｌ2000を利用していますが上記の処理ＶＢＡマクロをどうか教えてください。

回答No.2

fumufumu_2006 · ベストアンサー

範囲を選択してgetDataで作業シートにデータを作ります。
ついでに、putDataで現在の選択セルからに書き出します。
読み書きともActiveSheetに対して行うので、別シートのボタンなどで行う場合は、シートを指定してください。
この場合、Application.ScreenUpdating を設定してあげると、画面の表示を切り替えをしないので見栄えがいいです。

Option Explicit
Const workSheetName = "作業シート" '適当な作業シート

Sub getData()
Dim ws As Worksheet '作業用シート
Dim cellA() As String
Dim cellB() As String
Dim cellC() As String
Dim cellD() As String
Dim r As Long
Dim p As Long
Dim i As Integer

'Sheets(元データシート名).Select '元データシートを指定する場合
With Selection
'チェック
If .Columns.Count <> 4 Then
MsgBox "選択幅が間違っています"
Else
'作業シートにデータを作成
p = 1
Set ws = Sheets(workSheetName)
ws.Cells.Clear
For r = .Row To .Row + .Rows.Count - 1
'セルごとのデータを取得(セル内改行(LF)で分ける)
cellA = Split(Cells(r, .Column + 0), vbLf)
cellB = Split(Cells(r, .Column + 1), vbLf)
cellC = Split(Cells(r, .Column + 2), vbLf)
cellD = Split(Cells(r, .Column + 3), vbLf)
If UBound(cellB) <> -1 Then 'B列が空のセルならスキップ
'一応データの有効範囲を合わせる
ReDim Preserve cellA(0)
ReDim Preserve cellC(UBound(cellB))
ReDim Preserve cellD(UBound(cellB))
'bufに書き込む
For i = 0 To UBound(cellB)
If cellB(i) <> "" Then '改行だけの行もあるかもしれないので
ws.Cells(p, 1) = cellA(0) 'A列はいつも先頭
ws.Cells(p, 2) = cellB(i)
ws.Cells(p, 3) = cellC(i)
ws.Cells(p, 4) = cellD(i)
p = p + 1
End If
Next
End If
Next
End If
End With
End Sub

Sub putData()
Dim ws As Worksheet '作業用シート
Dim lastRow As Long

'Sheets(出力データシート名).Select '出力データシートを指定する場合
With Sheets(workSheetName)
If .Cells(1, 1) = "" Then
MsgBox "データがありません"
Else
'データ転送
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Range(Cells(Selection.Row, Selection.Column), Cells(Selection.Row + lastRow - 1, Selection.Column + 3)) = .Range(.Cells(1, 1), .Cells(lastRow, 4)).Value
'.Cells.Clear '多重ペースト防止用に作業データを消す場合
End If
End With
End Sub

お礼

お教えいただいた方法で意図する作業ができました。どうもありがとうございました。

回答No.1

imogasi

マクロを使わなくても
元シートのデータ範囲をコピーし（今回は質問の例データをコピーしてエクセルに貼り付けた）、新シートに貼り付ける。
山田の前のスペースが邪魔だったりするが、それのスペースを除いて
（大げさにやるならTRIM関数があるが手作業でどうか）
データー区切り位置ー次へースペースー完了で
担当者 日付 履歴 更新日
----------+---------------+------------+---------------+
山田 2001/1/1 札幌支店 2005/1/1
2002/1/1 福岡支店 2005/4/1
2003/4/1 東京支店 2005/4/1
のようになりましたよ。罫線のーーー＋が実際どういうモノか不明だが。
山田を全行入れるには
E列に=IF(A3="",E2,A3)
と入れて下方向に式を複写する。その後A列にE列の「値｝を複写して
式を消す。E列は列削除。

お礼

ご回答ありがとうございます。

質問の表記で-------------+-----------と記載しているのは
セルをイメージしました。Ａ1に「担当者」Ａ2に「山田」と記載しているイメージです。問題はB.C.D列のセル内容ですが前任者が一つのセルに改行を利用して入力しているため、内容を行に分割したいと考えています。件数が非常に多く手作業を排除した方法でＶＢＡを利用した方法がわかる方にお教えいただきたく投稿させていただきました。