(VBA)Split関数を使った文字列の区切りについて教えて頂けますでしょうか？

VBA初心者でSplit関数を使った文字列の区切りがどうしてもうまくいかず非常に困っております。
アドバイス頂けますでしょうか。宜しくお願い致します。


詳細を説明させて頂くと、
(1)エクセルシートのA2セルからA？？までの各セルにスペースを含んだ文字列がそれぞれ入力されており、そのそれぞれのセルをスペースで区切ってまず表示させる。
※データは常にシートのA２からはじまりA3, A4,・・・と不特定に数十行あります

（具体例は添付ファイルをご覧頂けますと幸いです。※画像が多少見づらいのですが、画面上のほうがもともとの表で、下の方が完成させたいイメージです。）

そして、実際にトライしてみたVBAのソース・・・（本当お恥ずかしいというか
情けないですが。。）

Sub data_split()
Dim buf As String, tmp, cnt As Long, I As Long
cnt = 2
buf = ThisWorksheet.Cells(cnt, 1).Value

'ループ処理(1)（２行目からセルが空になるまで行う処理）
Do Until Cells(cnt, 1) = ""
cnt = cnt + 1
tmp = split(buf, "")

' データ（文字列）をスペースで区切って出力。
For I = 0 To UBound(tmp)
Cells(cnt, I + 1) = tmp(I)
Next I
Loop
End Sub


(2)A列からD列までの文字列はそのままで、E列以降（F,G、H・・・）に入った文字列はすべてまとめてE列の各セルに入力させたい。

'AからDまでのセルに入ったセルはそのままでよい。
'E以降の区切られたデータは全部Hセルに入力する

VBA初心者なのですが、仕事上、取り急ぎこのようなイメージのVBAを作成しないといけないのですが、本やサイトを見ていろいろと試みているのですがどうしてもうまくいかず非常に困っております。。どうぞ宜しくお願い致します。

参考にしたサイト：http://officetanaka.net/excel/vba/tips/tips62.htm

No.2 ベストアンサー 回答者： Wendy02 回答日時： 2009/11/30 11:36

こんにちは。

質問の図で見る限りは、元の文章は、テキスト貼り付けではありませんか？

>A ピクニック　12月9日　A公園　持ち物は水筒、折りたたみ傘、　　参加人数不明。

貼り付けの図を見る限りは、
　・スペースは全角・半角とは限らない
　・スペースは、一つとは限らない
ということがいえると思います。

実務上は、区切り位置のほうがよいです。任意の切り分けを実現するのは、マクロでは、なかなか難しいです。
'-------------------------------------------

Sub TestMacro1()
　　Dim ar As Variant
　　Dim v As Variant
　　Dim buf As Variant
　　Dim pstRng As Range
　　Dim i As Long, j As Long
　　With ActiveSheet
　　　　Set pstRng = .Range("A11") '書き出し場所, 同じ場所なら、A2にする
　　　　
　　　　ar = .Range("A2", .Range("A2").End(xlDown)).Value '対象範囲
　　　　ar = Application.Transpose(ar) '１次元配列に変換
　　　　i = LBound(ar) '配列の下限を取る
　　　　For Each v In ar
　　　　　　'全角・半角のスペースの統一
　　　　　　buf = Replace(v, Space(1), Space(1), , , vbTextCompare)
　　　　　　'二つ以上のスペースを一つにする
　　　　　　Do
　　　　　　　　buf = Replace(buf, Space(2), Space(1), , , vbTextCompare)
　　　　　　Loop While InStr(buf, Space(2)) > 0
　　　　　　ar(i) = buf
　　　　　　buf = ""
　　　　　　i = i + 1
　　　　Next v
　　　　i = LBound(ar)
　　　　'Split 用に調整
　　　　For Each v In ar
　　　　　　'カンマ付けは、4個まで
　　　　　　ar(i) = Split(Replace(v, Space(1), ",", 1, 4), ",")
　　　　　　i = i + 1
　　　　Next
　　End With
　　'シートへの貼り付け
　　For i = LBound(ar) To UBound(ar)
　　　　For j = 0 To 4
　　　　　　If j < 4 Then
　　　　　　　　pstRng.Cells(i, j + 1).Value = ar(i)(j)
　　　　　　Else
　　　　　　　　'備考欄のスペースを除去
　　　　　　　　pstRng.Cells(i, j + 1).Value = Replace(ar(i)(j), Space(1), "")
　　　　　　End If
　　　　Next j
　　Next i
End Sub

この回答へのお礼

返答遅くなりましたが、いろいろと参考にさせていただきました！！有難うございます！！

お礼日時：2009/12/08 20:53

No.1 回答者： xls88 回答日時： 2009/11/30 04:55

下記で試してください。

区切り文字は、とりあえず全角スペースにしています。
違っていれば直してください。

Sub test1()
Dim r As Range
Dim c As Range
Dim d As Variant
Dim s As String
Dim i As Integer

Set r = Range("A2", Range("A2").End(xlDown))
For Each c In r
s = c.Value
d = Split(s, "　")
For i = 0 To 3
On Error Resume Next
c.Offset(, i).Value = d(i)
s = Replace(s, d(i) & "　", "", 1, 1)
On Error GoTo 0
Next i
c.Offset(, 4).Value = s
Next c
End Sub

この回答へのお礼

ご返答遅くなりましたが、頂いたソースを参考に解決いたしました。本当に有難うございました！！

お礼日時：2009/12/08 20:52