多张excel表导入access一个表

﹫゛史尐瘦﹌ · 发表于 2016-12-12 15:13

目前有40多个excel表，每个表中的sheet表的格式都相同，字段也相同，需要将每个表的每个sheet表都导入access的同一个表中，请各位高手帮帮忙吧，手工导入表格快吐血了，多谢多谢。

范例.rar (18.46 KB, 下载次数: 82)

﹫゛史尐瘦﹌ · 发表于 2016-12-12 18:01

各位大神帮帮忙吧，总体数据量大概有40多个表大概100多万行

opiona · 发表于 2016-12-12 21:03

遍历文件
遍历工作表
StrSQL = "INSERT INTO [字段设置表] SELECT * FROM [Excel 12.0;Database=" & OpenFileDialog1.FileName & "].[字段设置表$] "

26735619 · 发表于 2016-12-12 21:32

我也遇到同样的问题，求大神们帮帮忙

﹫゛史尐瘦﹌ · 发表于 2016-12-13 10:54

可否帮忙做一个例子呢？万分感谢了

﹫゛史尐瘦﹌ · 发表于 2016-12-15 14:11

各位大神啊，求帮助啊

grf1973 · 发表于 2016-12-15 15:27

打开mydata.accdb，在模块里修改mypath为数据源所在的地址即可。

Function 导入()
On Error GoTo 导入_Err
mypath = "C:\Documents and Settings\Administrator\桌面\范例\范例"
Filename = Dir(mypath & "\*.xlsx")
Do While Filename <> ""
fn = mypath & "" & Filename
DoCmd.TransferSpreadsheet acImport, 10, "收款表", fn, True, ""
Filename = Dir
Loop
导入_Exit:
Exit Function
导入_Err:
MsgBox Error$
Resume 导入_Exit
End Function

复制代码

魂断蓝桥 · 发表于 2016-12-15 15:30

Sub a()
'引用dao 3.6
Dim myDatabase As DAO.Database
Dim myDataTable As DAO.TableDef
Dim myDatabaseName As String
Dim myDataTableName As String
Dim myIndex As DAO.Index
myDatabaseName = ThisWorkbook.Path & "\测试.mdb"
myDataTableName = "数据"
On Error Resume Next
Kill myDatabaseName
On Error GoTo 0
Set myDatabase = CreateDatabase(myDatabaseName, dbLangGeneral)
Set myDataTable = myDatabase.CreateTableDef(myDataTableName)
   Dim arr
   arr = [a1].CurrentRegion
With myDataTable
      Set f = .CreateField("序号")
      f.Type = dbLong
      f.Attributes = dbAutoIncrField
      .Fields.Append f
      For i = 2 To UBound(arr)
         .Fields.Append .CreateField(arr(i, 1), arr(i, 2))
      Next
End With
myDatabase.TableDefs.Append myDataTable
Set myDatabase = Nothing
Call hb
End Sub
Sub hb()
Dim myfile$, mypath$
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "*.xlsx")
Dim Cnn As Object, rs As Object, SQL$, x As Integer, y As Integer, m As Integer, crr, brr(1 To 9999, 1 To 14)
Do While myfile <> ""
Set Cnn = CreateObject("ADODB.Connection")
Cnn.Open "Provider=Microsoft.ace.OleDb.12.0;Extended Properties='Excel 12.0;HDR=yes'; Data Source=" & mypath & myfile
SQL = "select * from [sheet1$A1:n] WHERE 收款方式 is not null "
Set rs = Cnn.Execute(SQL)
crr = rs.GetRows
      For m = 0 To UBound(crr, 2)
         x = x + 1
            For y = 1 To UBound(crr) + 1
                  brr(x, y) = crr(y - 1, m)
            Next
      Next
myfile = Dir()
Loop
[d2:z9999].ClearContents
[d2].Resize(x, 14) = brr
Cnn.Close
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\测试.mdb;"
SQL = "select * FROM [Excel 12.0;HDR=YES;DATABASE=" & ThisWorkbook.FullName & "].[sheet1$d1:q] where 收款方式 is not null"
SQL = "INSERT INTO 数据 (收款方式,收款账号,收款日期,入账日期,收款编号,币种,收款金额,发票编号,客户名称,客户编号,匹配的订单号,订单金额,已核销金额,未核销金额) " _
      & SQL
Cnn.Execute (SQL)
Cnn.Close
Set Cnn = Nothing
End Sub

范例.rar (49.67 KB, 下载次数: 109)

魂断蓝桥 · 发表于 2016-12-15 15:31

Sub a()
'引用dao 3.6
Dim myDatabase As DAO.Database
Dim myDataTable As DAO.TableDef
Dim myDatabaseName As String
Dim myDataTableName As String
Dim myIndex As DAO.Index
myDatabaseName = ThisWorkbook.Path & "\测试.mdb"
myDataTableName = "数据"
On Error Resume Next
Kill myDatabaseName
On Error GoTo 0
Set myDatabase = CreateDatabase(myDatabaseName, dbLangGeneral)
Set myDataTable = myDatabase.CreateTableDef(myDataTableName)
   Dim arr
   arr = [a1].CurrentRegion
With myDataTable
      Set f = .CreateField("序号")
      f.Type = dbLong
      f.Attributes = dbAutoIncrField

grf1973 · 发表于 2016-12-15 15:34

通过手动方式选择数据源文件夹。

Function 导入()
On Error GoTo 导入_Err
Dim fso, fl, fp
Set fso = CreateObject("Scripting.FileSystemObject")
fp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path & ""
For Each fl In fso.getfolder(fp).Files
If fl.Name Like "*.xlsx" Then DoCmd.TransferSpreadsheet acImport, 10, "收款表", fl, True, ""
Next
导入_Exit:
Exit Function
导入_Err:
MsgBox Error$
Resume 导入_Exit
End Function

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 多张excel表导入access一个表

评分

评分