急求助，ADO将EXCEL导入ACCESS运行时错误-2147467259 80004005

zhaogang1960

请参考：

1. Sub CertificatestoAccess()
   
2.     Dim cnn As New ADODB.Connection
   
3.     Dim rs As New ADODB.Recordset
   
4.     Dim Cat  As New ADOX.Catalog
   
5.     Dim myData$, myFile, h$
   
6.     myData = ThisWorkbook.Path & "\Data.accdb"
   
7.     myPath = ThisWorkbook.Path & ""
   
8.     myFile = Dir(myPath & "*拼单*.xls?")
   
9.     If myFile = "" Then
   
10.         MsgBox "无需更新", vbInformation, "提醒"
    
11.         Exit Sub
    
12.     End If
    
13.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & myData
    
14.     Do While myFile <> ""
    
15.         h = Right$(myFile, 4)
    
16.         If h = ".xls" Or h = ".xlsx" Then
    
17.             cnn.Execute "insert into Certificates SELECT f1 as [ACC Number],f3 as [Certificates] from [Excel 12.0;hdr=no;Database=" _
    
18.                 & myPath & myFile & "].[Sheet1$E7:G] where f1 is not null"
    
19.         End If
    
20.         myFile = Dir()
    
21.     Loop
    
22.     cnn.Close
    
23.     Set cnn = Nothing
    
24.     MsgBox "导入完成"
    
25. End Sub
    

复制代码

zhaogang1960

请测试附件
New folder.rar (40.25 KB, 下载次数: 33)

2015-12-26 12:09 上传

点击文件名下载附件

Bettyexcel

zhaogang1960 发表于 2015-12-25 22:56
请测试附件

感谢赵版，多谢！

Bettyexcel

zhaogang1960 发表于 2015-12-25 22:55
请参考：

感谢赵版，遇到了新问题。[Sheet1$E7:G] where f1 is not null 里的Sheet1的名字不是固定的，有时名字会变动，如何应对这种工作表名不确定的情况？

zhaogang1960

Bettyexcel 发表于 2015-12-30 15:49
感谢赵版，遇到了新问题。[Sheet1$E7:G] where f1 is not null 里的Sheet1的名字不是固定的，有时名字会 ...

1. Sub CertificatestoAccess()
   
2.     Dim cnn As New ADODB.Connection
   
3.     Dim cat  As New ADOX.Catalog
   
4.     Dim myData$, myFile, h$, tb1, s$
   
5.     myData = ThisWorkbook.Path & "\Data.accdb"
   
6.     myPath = ThisWorkbook.Path & ""
   
7.     myFile = Dir(myPath & "*拼单*.xls?")
   
8.     If myFile = "" Then
   
9.         MsgBox "无需更新", vbInformation, "提醒"
   
10.         Exit Sub
    
11.     End If
    
12.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & myData
    
13.     Do While myFile <> ""
    
14.         h = Right$(myFile, 4)
    
15.         If h = ".xls" Or h = "xlsx" Then
    
16.             cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & myPath & myFile
    
17.             For Each tb1 In cat.Tables
    
18.                 If tb1.Type = "TABLE" Then
    
19.                     s = Replace(tb1.Name, "'", "")
    
20.                     If Right(s, 1) = "$" Then
    
21.                         cnn.Execute "insert into Certificates SELECT f1 as [ACC Number],f3 as [Certificates] from [Excel 12.0;hdr=no;Database=" _
    
22.                             & myPath & myFile & "].[" & s & "E7:G] where f1 is not null"
    
23.                     End If
    
24.                 End If
    
25.             Next
    
26.         End If
    
27.         myFile = Dir()
    
28.     Loop
    
29.     Set cat = Nothing
    
30.     cnn.Close
    
31.     Set cnn = Nothing
    
32.     MsgBox "导入完成"
    
33. End Sub
    

复制代码

zhaogang1960

请测试附件
New folder.rar (41.81 KB, 下载次数: 32)

2015-12-30 16:17 上传

点击文件名下载附件

Bettyexcel

zhaogang1960 发表于 2015-12-30 16:17
请测试附件

赵版，不好意思，劳您移步到以下链接的帖子看看行吗？谢谢了！！

求助！文本框的内容如何通过UPDATE语句写入ACCESS
http://club.excelhome.net/thread-1279035-1-1.html
(出处: ExcelHome技术论坛)