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
お礼
参考になりました。 ありがとうございました。