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

Bettyexcel · 发表于 2015-11-4 10:39

zhaogang1960 发表于 2015-11-3 17:15
附件…………………………

非常非常感谢赵版！
还有一问题劳您再看看，EXCEL的Sheet1导入ACCESS后，在ACCESS里它的名字不叫Sheet1，它的名字我想叫AList，即原EXCEL工作簿的名字。

zhaogang1960 · 发表于 2015-11-4 15:12

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 = Split(p, " ")(0) & Split(p, " ")(1)
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 & ";].[Sheet1$]"
cnn.Execute SQL
MsgBox " 成功导入 ", vbInformation, " 导入数据库 "
cnn.Close
Set cnn = Nothing
End Sub

复制代码

zhaogang1960 · 发表于 2015-11-4 15:13

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

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

Bettyexcel · 发表于 2015-11-4 17:01

zhaogang1960 发表于 2015-11-4 15:13
附件……………………………………

再次感谢赵版！在每次编写VBA心灰意冷的时候伸出了您的援手让我有动力继续走下去，谢谢！

Bettyexcel · 发表于 2015-11-5 11:41

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

赵版，
工作的难度又增加了，EXCEL表格内的格式变了，我在AList里备注了，劳您再帮忙看看新问题好吗？谢谢！

zhaogang1960 · 发表于 2015-11-5 16:36

Bettyexcel 发表于 2015-11-5 11:41
赵版，
工作的难度又增加了，EXCEL表格内的格式变了，我在AList里备注了，劳您再帮忙看看新问题好吗？谢 ...

仅有Order和Time1衍生出来的两列？如果是请测试：

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 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
SQL = "SELECT REPLACE(Order,' ','') AS [Acc Number],REPLACE(Time1,'.','-') AS [Entry Time] INTO [" & MyTable & "] FROM [Excel 12.0;Database=" & myPath & p & ";].[" & s & "]"
cnn.Execute SQL
End If
End If
Next
MsgBox " 成功导入 ", vbInformation, " 导入数据库 "
If Not F Then
rs.Close
Set rs = Nothing
End If
cnn.Close
Set cnn = Nothing
Set cat = Nothing
End Sub

复制代码

zhaogang1960 · 发表于 2015-11-5 16:38

Bettyexcel 发表于 2015-11-5 11:41
赵版，
工作的难度又增加了，EXCEL表格内的格式变了，我在AList里备注了，劳您再帮忙看看新问题好吗？谢 ...

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

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

潇戈 · 发表于 2015-11-5 17:06

zhaogang1960大师你以前有过类似的帖子，请帮忙看看，网址是：http://club.excelhome.net/thread-1234948-1-1.html

Bettyexcel · 发表于 2015-11-5 17:31

zhaogang1960 发表于 2015-11-5 16:38
附件……………………………………

谢谢赵版。但还有一点差异，劳驾您再看看。真不好意思，一直麻烦您了。但本人的能力真的太有限了，抱歉了。

zhaogang1960 · 发表于 2015-11-5 17:40

Bettyexcel 发表于 2015-11-5 17:31
谢谢赵版。但还有一点差异，劳驾您再看看。真不好意思，一直麻烦您了。但本人的能力真的太有限了，抱歉了 ...

一、字段名有句点
二、每个表都不能确定的字段名
这个问题我不会，抱歉

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

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

评分

评分