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

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

　　　Ａ　　　　　　　　　Ｂ　　　　　　　　　　　Ｃ　　　　　　　　　　Ｄ
　----------+---------------+------------+---------------+　
　担当者　　　　　　日付　　　　　　　　　履歴　　　　　　　　更新日
　----------+---------------+------------+---------------+
　山田　　　　　　　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
　----------+---------------+------------+---------------+

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

No.2 ベストアンサー 回答者： redfox63 回答日時： 2008/01/14 11:28

Sheet2には最低限項目名が記入されていると仮定しています

下記のような感じでしょう
Sub Macro1()
　　Dim r1 As Range, r2 As Range, s As String
　　Dim ar() As String, n As Integer, m As Integer, i As Integer
　　' Sheet1のA2セルから開始
　　Set r1 = Sheet1.Range("A2")
　　' Sheet2のA列の最後+1行目から開始
　　Set r2 = Sheet2.Range("A65536").End(xlUp).Offset(1)
　　' Sheet1のデータが無くなるまでループ
　　Do While r1.Value <> ""
　　　　' セル内改行の最大数を記憶するための変数iを初期化
　　　　i = 0
　　　　For m = 1 To 3
　　　　　　' Sheet1の B,C,D列のデータをLFで分割
　　　　　　ar = Split(r1.Offset(0, m).Value, vbLf)
　　　　　　For n = 0 To UBound(ar)
　　　　　　　　' Sheet2へ転記
　　　　　　　　r2.Offset(n, m).Value = ar(n)
　　　　　　Next
　　　　　　' 分割数の最大値を判断
　　　　　　If UBound(ar) + 1 > i Then i = UBound(ar) + 1
　　　　Next
　　　　s = r0.Value
　　　　' Sheet2のA列に転記
　　　　r2.Resize(i, 1).Value = s
　　　　' Sheet1を次行に移動
　　　　Set r1 = r1.Offset(1)
　　　　' Sheet2を転記した次の行に移動
　　　　Set r2 = r2.Offset(i)
　　Loop
End Sub

この回答へのお礼

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

お礼日時：2008/01/14 13:12

No.4 回答者： n-jun 回答日時： 2008/01/14 12:09

ANo.3です。

ミスしてました。

＞ReDim　Preserve　v(1　To　4,　1　To　i　-　1)
を
ReDim　Preserve　v(1　To　4,　1　To　i)
に変更願います。

この回答へのお礼

お教えいただいた方法を参考にさせていただきます。どうもありがとうございました。

お礼日時：2008/01/14 13:13

No.3 回答者： n-jun 回答日時： 2008/01/14 12:05

シート１からシート２へ書き出すサンプル。

Sub　try()
　Dim　r　As　Range
　Dim　v,　vv1,　vv2,　vv3
　Dim　i　As　Long,　k　As　Integer

　With　Worksheets("Sheet1")
　　　　　　ReDim　v(1　To　4,　1　To　.Cells.Rows.Count)

　　　　　　For　Each　r　In　.Range(.[A2],　.Cells(Rows.Count,　1).End(xlUp))
　　　　　　　　　　vv1　=　Split(r.Offset(,　1).Value,　vbLf)
　　　　　　　　　　vv2　=　Split(r.Offset(,　2).Value,　vbLf)
　　　　　　　　　　vv3　=　Split(r.Offset(,　3).Value,　vbLf)
　　　　　　　　　　
　　　　　　　　　　For　k　=　0　To　UBound(vv1)
　　　　　　　　　　　　　　i　=　i　+　1
　　　　　　　　　　　　　　v(1,　i)　=　r.Value
　　　　　　　　　　　　　　v(2,　i)　=　vv1(k)
　　　　　　　　　　　　　　v(3,　i)　=　vv2(k)
　　　　　　　　　　　　　　v(4,　i)　=　vv3(k)
　　　　　　　　　　Next
　　　　　　Next
　　　　　　ReDim　Preserve　v(1　To　4,　1　To　i　-　1)
　End　With
　With　Worksheets("Sheet2")
　　　　　　.Range("A1:D1").Value　=　Array("担当者",　"日付",　"履歴",　"更新日")
　　　　　　.Range("A2").Resize(UBound(v,　2),　4).Value　=　Application.Transpose(v)
　End　With
　Erase　v
End　Sub
ご参考になれば。

No.1 回答者： pbforce 回答日時： 2008/01/14 11:18

Sub test()

strTest = Cells(1, 1).Value
Cells(1, 2) = InStr(1, strTest, vbLf)
End Sub

でセル内の改行位置を判定できます。
セル内のvbLfを探せば文字を分割する位置が判断できます。

この回答へのお礼

判定条件を理解しました。ありがとうございました。

お礼日時：2008/01/14 13:11