複数csvファイルのデータとファイル名をひとつのACCESSのテーブルにインポートしたい

質問

1,000個以上のcsvファイルを、C:\tool\csvfiles\に格納し、C:\tool\にあるACCESSファイルのテーブル、「importfiles」にインポートするプログラムをVBAを作成したいです。

条件は、以下を満たしたいです。
・1番右のフィールドにファイル名を追加したい
・それぞれのフィールドについて、データ型を指定したい

■CSVファイルのサンプル
ファイル名(1)：0009_xxx_0001.CSV
データ内容(1)：
部署コード　請求コード　日時　　料金
0001　　　1234　　　090730　100
0001　　　1235　　　090730　150

ファイル名(2)：0009_xzy_0002.CSV
データ内容(2)：
部署コード　請求コード　日時　　料金
0002　　　2234　　　090730　100
0002　　　2235　　　090730　150

■ACCESSでやりたいこと
テーブル名：importfiles
データ内容：
ファイル名　　　　　部署コード　請求コード　日時　　料金
0009_xxx_0001.CSV　 0001　　　1234　　　090730　100
0009_xxx_0001.CSV　 0001　　　1235　　　090730　150
0009_xzy_0002.CSV 0002　　　2234　　　090730　100
0009_xzy_0002.CSV 0002　　　2235　　　090730　150

データ型は料金は料金は数値型、それ以外はテキスト型です。
ACCESS 2003を試用しております。

transfertextではファイル名が取得できず、ほかの方法も見当がつかず、本当に困っています。
どなたかご存知の方、よろしくお願いいたします。

回答No.1

mitarashi · ベストアンサー

ファイル１個分だけです。ファイルの数だけループを回すところはご自分でお願いします。あらかじめテーブル1というテーブルを作成し、データ型等を設定しておきます。
'☆　標準モジュール
Option Compare Database
Option Explicit

Sub test()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim FSO As Object
Dim srcFilePath As String, srcFileName As String
Dim lineCounter As Long
Dim buf As Variant

Set cn = CurrentProject.Connection
Set rs = New ADODB.Recordset
srcFilePath = "C:\Documents and Settings\?????\デスクトップ\Book1.csv"
rs.Open "テーブル1", cn, adOpenKeyset, adLockOptimistic
Set FSO = CreateObject("Scripting.FileSystemObject")
lineCounter = 1
srcFileName = FSO.GetFileName(srcFilePath)
With FSO.GetFile(srcFilePath).OpenAsTextStream
Do While Not .AtEndOfLine
buf = Split(.ReadLine, ",")
If lineCounter > 1 Then
rs.AddNew
rs!ファイル名 = srcFileName
rs!部署コード = buf(0)
rs!請求コード = buf(1)
rs!日時 = buf(2)
rs!料金 = buf(3)
rs.Update
End If
lineCounter = lineCounter + 1
Loop
.Close
End With
Set FSO = Nothing
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
End Sub
参考URL
ADO
http://mail.accessclub.jp/ado/index.html
FSO
http://officetanaka.net/excel/vba/filesystemobject/index.htm

お礼

mitarashiさん

御礼が遅くなり申し訳ございません。ほかの業務におわれておりました。
ありがとうございます！あとは複数のCSVファイルをインポートできるようにがんばってみます！