Sub 联合查询后导入() 'VBA中测试通过
'引用Microsoft ActiveX Data Objects 2.x Library
'VB6批量读取CSV文件到access?
'http://club.excelhome.net/thread-973334-1-1.html
Dim xlapp As Object
Dim cnn As New ADODB.Connection
Dim myPath$, MyFile$, SQL$
Set xlapp = GetObject(, "Excel.Application") 'VB6中
myPath = xlapp.ActiveWorkbook.Path & ""
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & myPath & "Database.accdb" '连接数据库
MyFile = Dir(myPath & "*.csv")
Do While MyFile <> "" '创建多个文本文件的联合查询
If Len(SQL) Then
SQL = SQL & " union all select '" & Mid(MyFile, 10, 7) & "' as FormID,'" & Mid(MyFile, 1, 8) & "' as FormType,f1 as ModelName,f4 as ModelVersion,f3 as OutPutQty,f2 as ProductionLine from [Text;FMT=Delimited;HDR=no;DATABASE=" & myPath & ";].[" & MyFile & "]"
Else
SQL = "select '" & Mid(MyFile, 10, 7) & "' as FormID,'" & Mid(MyFile, 1, 8) & "' as FormType,f1 as ModelName,f4 as ModelVersion,f3 as OutPutQty,f2 as ProductionLine from [Text;FMT=Delimited;HDR=no;DATABASE=" & myPath & ";].[" & MyFile & "]"
End If
MyFile = Dir()
Loop
SQL = "insert into BackflushRecord select * from (" & SQL & ")" '向access数据表中添加数据语句
cnn.Execute SQL
MsgBox "已经成功将文本文件数据保存为数据库!", vbInformation
cnn.Close
Set cnn = Nothing
End Sub