VBAの初心者でやりたいことがあるのですが、どうやっていいのか分かりま

VBAの初心者でやりたいことがあるのですが、どうやっていいのか分かりません。
やりたいことは
1.フォルダを指定してCSVファイルを読み込む。
2.読み込んだCSVファイルを一行あたり1ファイルのエクセルファイルに書き込む。
3.完成したエクセルファイルを印刷する。
4.フォルダの中のファイルが無くなれば終了
としたいのですが、途中で頓挫しています。
宜しくお願いします。
Option Explicit
sub READ_TextFile()
Const cnsTITLE = "フォルダ内のファイル名一覧取得"
Const cnsDIR = "\*.*"
Dim xlAPP As Application
Dim strPATHNAME As String
Dim strFILENAME As String
Dim GYO As Long
Const cnsFILTER = "全てのファイル (*.*),*.*"
Dim xlAPP2 As Application' Applicationオブジェクト
Dim intFF As Integer' FreeFile値
Dim X() As Variant' 読み込んだレコード内容
Dim IX1 As Long' CSV項目カラムINDEX
Dim lngREC As Long' レコード件数カウンタ
Dim strREC As String' レコード領域
Dim POS1 As Long' レコード文字位置
Dim POS2 As Long' レコード文字位置
Set xlAPP = Application
strPATHNAME = xlAPP.InputBox("フォルダ名を入力して下さい。", _
cnsTITLE, "C:\Documents and Settings\hidekazu_miyawaki\デスクトップ\")
If StrConv(strPATHNAME, vbUpperCase) = "FALSE" Then Exit Sub
If Dir(strPATHNAME, vbDirectory) = "" Then
MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTITLE
Exit Sub
End If
strFILENAME = Dir(strPATHNAME & cnsDIR, vbNormal)
Set xlAPP2 = Application
Do While strFILENAME <> ""
GYO = GYO + 1
Cells(GYO, 1).Value = strFILENAME
strFILENAME = Dir()
Open strFILENAME For Input As #intFF
GYO = 1
Do Until EOF(intFF)
lngREC = lngREC + 1
xlAPP2.StatusBar = "読み込み中です(" & lngREC & "レコード目)"
Line Input #intFF, strREC
POS1 = 1
IX1 = 0
ReDim X(IX1)
Do While POS1 <= Len(strREC)
POS2 = InStr(POS1, strREC, ",", vbTextCompare)
If POS2 < POS1 Then
POS2 = Len(strREC) + 1
End If
ReDim Preserve X(IX1)
X(IX1) = Trim$(Mid$(strREC, POS1, POS2 - POS1))
If (((Left$(X(IX1), 1) = """") And (Right$(X(IX1), 1) = """")) Or _
((Left$(X(IX1), 1) = "'") And (Right$(X(IX1), 1) = "'"))) Then
X(IX1) = Trim$(Mid$(X(IX1), 2, Len(X(IX1)) - 2))
End If
POS1 = POS2 + 1
IX1 = IX1 + 1
Loop
GYO = GYO + 1
If IX1 >= 1 Then
Range(Cells(GYO, 1), Cells(GYO, IX1)).Value = X
End If
Loop
Loop
Close #intFF
xlAPP.StatusBar = False
MsgBox "ファイル読み込みが完了しました。" & vbCr & _
"レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
End Sub

No.3 ベストアンサー 回答者： DOUGLAS_ 回答日時： 2010/04/24 21:25

#2 DOUGLAS_ です。

　ご質問文内にお示しの コード【Ａ】は、【Ｂ】フォルダ内のファイル一覧の取得
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub0 …
と、【Ｃ】CSV形式テキストデータの読み込み(カンマ数不定版)
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub0 …
をご参考にされたようですので、前回答を取消して、下記のように改めます。


　２つの VBA を合併していらっしゃいますが、内容的には【Ｂ】の中に【Ｃ】を入れていますので、【Ｂ】の中の「Cells(GYO, 1).Value = strFILENAME」と「strFILENAME = Dir()」との間に【Ｃ】の コード を挿入することになりますね。

　【Ａ】【Ｂ】【Ｃ】を並べて比較してみますと、「定数・配列の宣言部」は別として、コーディング の順序に誤りが３ヶ所あることに気がつきます。

　１つ目は、【Ｃ】の作業に入るところの先頭にある「intFF = FreeFile」が漏れ落ちていること、もう一つは、【Ｂ】の最後の「strFILENAME = Dir()」と「Loop」とが【Ｃ】の操作の途中に入ってしまっていること、最後の１つは、【Ｃ】の途中の「GYO = 1」が残ったままになっていますので、ファイル名 が変わるたびに「GYO」が初期化されてしまっていることです。

　更に、strFILENAME について、【Ｂ】と【Ｃ】で共用していらっしゃいますが、【Ｂ】の strFILENAME は [GetOpenFilename メソッド] で取得された「D:\hoge\hoge.csv」というような フルパス 文字列であるのに対して、【Ａ】【Ｃ】では [Dir 関数] で取得された「hoge.csv」というような ファイル名 だけの文字列になっています。


　従って【Ａ】の誤りは、
１）３１行目の「strFILENAME = Dir()」の次に
intFF = FreeFile
を挿入
２）３２行目の「Open strFILENAME For Input As #intFF」を
Open strPATHNAME & "\" & strFILENAME For Input As #intFF
に改める
３）３３行目「GYO = 1」を削除
４）３１行目の「strFILENAME = Dir()」と６０行目の「Loop」とを６１行目の「Close #intFF」の後ろに「Close #intFF」・「strFILENAME = Dir()」・「Loop」
の順序になるように移動
することによって改善されます。


　ついでに、【Ａ】を具に拝見いたしまして、いろいろと気にかかった点を列挙いたします。

１）９行目で宣言していらっしゃる「cnsFILTER」はどこにも出てきませんね。
　コード をいろいろと弄り回した後には、定数・変数などにも一通り目を通して、不要なものは削除する習慣を付けられることをお薦めいたします。

２）Application オブジェクト を「xlAPP」・「xlAPP2」として２つの変数で宣言されていますが、「xlAPP」だけで構いません。

３）「strFILENAME = Dir(strPATHNAME & cnsDIR, vbNormal)」のところは、対象 strFILENAME が CSVファイル のみでしたら、
strFILENAME = Dir(strPATHNAME & "\*.CSV")
とすることもできます。

４）「3.完成したエクセルファイルを印刷する。」につきましては、「End Sub」の前に
ActiveWindow.SelectedSheets.PrintOut
を挿入すればできます。

５）#1 さんがお示しの [Split 関数] の件に付きましては、「Dim POS1 As Long」を
Dim POS As Variant
とし、「Do Until EOF(intFF)」から２つ目の「Loop」までを下記のように改めれば可能となります。

Do Until EOF(intFF)
lngREC = lngREC + 1
Line Input #intFF, strREC
GYO = GYO + 1
POS = Split(strREC, ",")
Cells(GYO, 1).Resize(, UBound(POS) + 1) = POS
Loop

No.4 回答者： mitarashi 回答日時： 2010/04/24 22:43

#1です

DOUGLAS_さんの熱意に感服
CSVファイル名と、貼り付ける先頭セルを与えると、先頭セル以降の行内に、CSVファイル全体を貼り付ける関数を試しに作成してみました。改行コードはCRLFを前提としています。
こうやって、ループの外に出すと、すっきりして分かり易くなると思います。
なお、関数中のエラー処理はA列を先頭に貼り付ける事を前提としています。(^^;)
Sub test()
Call test2(ThisWorkbook.Path & "\Book1.csv", ActiveSheet.Range("A1"))
End Sub

Private Sub test2(filePath As String, destRange As Range)
Dim FSO As Object, TextFile As Object
Dim buf As String, buf2 As Variant

Set FSO = CreateObject("Scripting.FileSystemObject")
Set TextFile = FSO.OpenTextFile(filePath)
buf = TextFile.ReadAll
buf = Replace(buf, vbCrLf, ",")
buf2 = Split(buf, ",")
If UBound(buf2) > destRange.Parent.Columns.Count Then
MsgBox ("データ数が多すぎます")
Exit Sub
End If
destRange.Resize(1, UBound(buf2)) = buf2
Set TextFile = Nothing
Set FSO = Nothing
End Sub

No.2 回答者： DOUGLAS_ 回答日時： 2010/04/24 15:39

＞3.完成したエクセルファイルを印刷する。

は別として、とりあえず、下記のようにして、お試しください。

１）２９行目「GYO = GYO + 1」の後に
intFF = intFF + 1
を挿入
２）３１行目「strFILENAME = Dir()」を、５９行目「Loop」と、６０行目「Loop」との間に移動
３）３３行目「GYO = 1」を削除

No.1 回答者： mitarashi 回答日時： 2010/04/24 15:14

ざっと眺めてみましたが、随分難しくやっている気がします。

>2.読み込んだCSVファイルを一行あたり1ファイルのエクセルファイルに書き込む。
ここの意味が分かりにくいですね。
CSVファイル１個の内容をエクセルの一行に書き込み、指定フォルダに存在する全CSVファイルの内容を、エクセルの１シートにまとめる
という事をやろうとしているのでしょうか？
素直に読むと、CSVファイルの一行毎にエクセルファイルを一つ作ると読めますが、一行ごと印刷してもしょうがなさそうですし．．．

なお、CSVの一行を分解するのは、Split関数を用いると簡単です。
http://officetanaka.net/excel/vba/tips/tips62.htm