EXCEL导入到ACCESS里的vba代码有问题求助

Bettyexcel · 发表于 2015-11-3 11:47

达人们，请求协助。

以“A list *" 开头命名的工作簿是别人发来的数据，我凭此核对。将此表以全部更新的方式导入到ACCESS里。

即，如果以 “A list *" 开头命名的EXCEL工作簿存在，则VBA可通过先删除原ACCESS里同名的“Alist”数据表然后用新建一个名为“Alist”的数据表导入到ACCESS。
而，如果以 “A list *" 开头命名的EXCEL工作簿不存在，则提示 “无需更新”。
参考大家的例子写了个VBA，但无法执行，请大家帮忙看看，谢谢！

xd3210 · 发表于 2015-11-3 14:40

本帖最后由 xd3210 于 2015-11-3 15:18 编辑

Sub Button1_Click()
Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual

'引用Microsoft ActiveX Data Objects 2.x Library
'引用Microsoft AD0 Ext 2.8 for DDL and Security
Dim cnn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim Cat As New ADOX.Catalog
Dim myPath As String
Dim p
Dim sh As Worksheet
Dim SQL As String
Dim F As Boolean
Dim wk As Workbook

myPath = ThisWorkbook.Path & "\"
myData = ThisWorkbook.Path & "\data.accdb"
p = Dir(myPath & "A list *.xls?")
Set wk = Workbooks.Open(ThisWorkbook.Path & "\" & p)
If Not wk Is Nothing Then
      If Dir(myData) = "" Then
         Cat.Create "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
         Set Cat = Nothing
         F = True '数据库文件不存在标志
      End If

      cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
      For Each sh In Worksheets
         If Not F Then '数据库文件已经存在，先判断同名数据表是否存在，如果存在就删除它
            Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, sh.Name, Empty))
            If Not rs.EOF Then
                  SQL = "DROP TABLE " & sh.Name
                  cnn.Execute SQL
            End If
         End If
         SQL = "SELECT * INTO " & sh.Name & " FROM [Excel 12.0;Database=" & wk.FullName _
            & ";].[sheet1$" & Range("a1").CurrentRegion.Address(0, 0) & "]"
         cnn.Execute SQL

      Next
      MsgBox " 成功导入 ", vbInformation, " 导入数据库 "
      cnn.Close
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic
      Set cnn = Nothing
Else
      MsgBox "无须更新"
End If
End Sub

Bettyexcel · 发表于 2015-11-3 15:13

xd3210 发表于 2015-11-3 14:40
Sub Button1_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalcul ...

感谢亲。但我只需要Sheet1数据。其他SHEET的不需要了。帮我再改改好吗？

zhaogang1960 · 发表于 2015-11-3 15:28

本帖最后由 zhaogang1960 于 2015-11-3 15:36 编辑

不需要打开数据源工作簿,这也是ADO大批量处理工作簿的一个优点：

Sub Button1_Click()
'引用Microsoft ActiveX Data Objects 2.x Library
'引用Microsoft AD0 Ext 2.8 for DDL and Security
Dim cnn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim rst As ADODB.Recordset
Dim cat As New ADOX.Catalog
Dim tb1 As ADOX.Table
Dim myPath As String
Dim myData As String
Dim p As String
Dim sh As Worksheet
Dim SQL As String
Dim F As Boolean
myPath = ThisWorkbook.Path & ""
p = Dir(myPath & "A list *.xls?")
If p = "" Then
MsgBox "没有发现数据源工作簿，无需更新。", vbInformation, "提醒"
Exit Sub
End If
myData = myPath & "data.accdb"
If Dir(myData) = "" Then
cat.Create "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
F = True '数据库文件不存在标志
End If
cat.ActiveConnection = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & myPath & p
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
For Each tb1 In cat.Tables
If tb1.Type = "TABLE" Then
s = Replace(tb1.Name, "'", "")
If Right(s, 1) = "$" Then
MyTable = Replace(s, "$", "")
If Not F Then '数据库文件已经存在，先判断同名数据表是否存在，如果存在就删除它
Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, MyTable, Empty))
If Not rs.EOF Then
SQL = "DROP TABLE " & MyTable
cnn.Execute SQL
End If
End If
Set rst = cnn.Execute("[Excel 12.0;Database=" & myPath & p & ";].[" & s & "]")
If Not rst.EOF Then
SQL = "SELECT * INTO " & MyTable & " FROM [Excel 12.0;Database=" & myPath & p & ";].[" & s & "]"
cnn.Execute SQL
End If
End If
End If
Next
MsgBox " 成功导入 ", vbInformation, " 导入数据库 "
If Not F Then
rs.Close
Set rs = Nothing
End If
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Set cat = Nothing
End Sub

复制代码

zhaogang1960 · 发表于 2015-11-3 15:30

本帖最后由 zhaogang1960 于 2015-11-3 15:37 编辑

请测试附件

以整个表更新的方式导入数据到ACCESS.rar (29.12 KB, 下载次数: 67)

Bettyexcel · 发表于 2015-11-3 16:02

zhaogang1960 发表于 2015-11-3 15:28
不需要打开数据源工作簿,这也是ADO大批量处理工作簿的一个优点：

感谢赵版。我还有2个问题劳您指点：
1. AList 的EXCEL表里，我固定只需要 Sheet1 的数据，其他sheet的数据不需要导入了。如何固定只要Sheet1的数据即可？
2. AList 的EXCEL表是人家发来的数据，实际上他们使用了单词缩写，如附件显示：NO. 和 Asset.NO. 您知道 “." 导入ACCESS后变成了“#”，这样不利于我数据核对，可否用代码设定固定的标题行？

zhaogang1960 · 发表于 2015-11-3 16:47

Bettyexcel 发表于 2015-11-3 16:02
感谢赵版。我还有2个问题劳您指点：
1. AList 的EXCEL表里，我固定只需要 Sheet1 的数据，其他sheet的 ...

句点不能用于数据表字段名，即使用专门生成数据表的语句也无法完成，手工把工作簿导入到Access也不行，你可以手工导入试试看

Bettyexcel · 发表于 2015-11-3 17:04

zhaogang1960 发表于 2015-11-3 16:47
句点不能用于数据表字段名，即使用专门生成数据表的语句也无法完成，手工把工作簿导入到Access也不行，你 ...

好的，明白了。第一点如何固定只导入SHEET1的数据呢？这个可否帮忙？谢谢！

zhaogang1960 · 发表于 2015-11-3 17:14

Bettyexcel 发表于 2015-11-3 17:04
好的，明白了。第一点如何固定只导入SHEET1的数据呢？这个可否帮忙？谢谢！

Sub Button1_Click()
'引用Microsoft ActiveX Data Objects 2.x Library
'引用Microsoft AD0 Ext 2.8 for DDL and Security
Dim cnn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim cat As New ADOX.Catalog
Dim myPath As String
Dim myData As String
Dim p As String
Dim SQL As String
Dim F As Boolean
myPath = ThisWorkbook.Path & ""
p = Dir(myPath & "A list *.xls?")
If p = "" Then
MsgBox "没有发现数据源工作簿，无需更新。", vbInformation, "提醒"
Exit Sub
End If
myData = myPath & "data.accdb"
MyTable = "Sheet1"
If Dir(myData) = "" Then
cat.Create "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
Set cat = Nothing
F = True
End If
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
If Not F Then
Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, MyTable, Empty))
If Not rs.EOF Then
SQL = "DROP TABLE " & MyTable
cnn.Execute SQL
End If
rs.Close
Set rs = Nothing
End If
SQL = "SELECT * INTO " & MyTable & " FROM [Excel 12.0;Database=" & myPath & p & ";].[" & MyTable & "$]"
cnn.Execute SQL
MsgBox " 成功导入 ", vbInformation, " 导入数据库 "
cnn.Close
Set cnn = Nothing
End Sub

复制代码

zhaogang1960 · 发表于 2015-11-3 17:15

附件…………………………

以整个表更新的方式导入数据到ACCESS.rar (28.64 KB, 下载次数: 50)

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

[求助] EXCEL导入到ACCESS里的vba代码有问题求助

评分

评分

评分