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

Bettyexcel

zhaogang1960 发表于 2015-11-25 20:48
字典法：

感谢赵版。但只需要导入B列和C列到ACCESS就可以了，其他列不用导了。

zhaogang1960

Bettyexcel 发表于 2015-11-26 10:32
感谢赵版。但只需要导入B列和C列到ACCESS就可以了，其他列不用导了。

1. Sub Button1_Click()
   
2.     Dim cnn As New ADODB.Connection
   
3.     Dim rs As ADODB.Recordset
   
4.     Dim Cat As New ADOX.Catalog
   
5.     Dim myPath As String
   
6.     Dim myData As String
   
7.     Dim p As String
   
8.     Dim SQL As String
   
9.     Dim d As Object, arr, brr(), i&, j&, m&
   
10.     myPath = ThisWorkbook.Path & ""
    
11.     p = Dir(myPath & "A list *.xls?")
    
12.     If p = "" Then
    
13.         MsgBox "没有发现数据源工作簿，无需更新。", vbInformation, "提醒"
    
14.         Exit Sub
    
15.     End If
    
16.     myData = myPath & "data.accdb"
    
17.     myTable = Split(p, " ")(0) & Split(p, " ")(1)
    
18.     If Dir(myData) = "" Then Cat.Create "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
    
19.     cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
    
20.     Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, myTable, Empty))
    
21.     If rs.EOF Then
    
22.         SQL = "CREATE TABLE " & myTable & "([Number] text(50),[Assetment Number] LONGTEXT)"
    
23.     Else
    
24.         SQL = "DELETE FROM " & myTable
    
25.     End If
    
26.     cnn.Execute SQL
    
27.     Set d = CreateObject("scripting.dictionary")
    
28.     SQL = "SELECT * FROM [Excel 12.0;Database=" & myPath & p & ";].[Sheet1$a2:d]"
    
29.     arr = cnn.Execute(SQL).GetRows
    
30.     ReDim brr(1 To UBound(arr, 2) + 1, 0 To 2)
    
31.     For i = 0 To UBound(arr, 2)
    
32.         If Not d.Exists(arr(1, i)) Then
    
33.             m = m + 1
    
34.             d(arr(1, i)) = m
    
35.             For j = 1 To 2
    
36.                 brr(m, j) = arr(j, i)
    
37.             Next
    
38.         Else
    
39.             brr(d(arr(1, i)), 2) = brr(d(arr(1, i)), 2) & "," & arr(2, i)
    
40.         End If
    
41.     Next
    
42.     SQL = "SELECT * FROM " & myTable & " WHERE 1=2"
    
43.     Set rs = New ADODB.Recordset
    
44.     rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    
45.     For i = 1 To m
    
46.         rs.AddNew
    
47.         For j = 0 To 1
    
48.             rs.Fields(j) = brr(i, j + 1)
    
49.         Next
    
50.         rs.Update
    
51.     Next
    
52.     MsgBox " 成功导入 ", vbInformation, " 导入数据库 "
    
53.     rs.Close
    
54.     cnn.Close
    
55.     Set rs = Nothing
    
56.     Set cnn = Nothing
    
57.     Set Cat = Nothing
    
58. End Sub
    

复制代码

zhaogang1960

附件………………………………
以整个表更新的方式导入数据到ACCESS.rar (29.58 KB, 下载次数: 23)

2015-11-26 12:09 上传

点击文件名下载附件

Bettyexcel

zhaogang1960 发表于 2015-11-26 12:09
附件………………………………

谢谢赵版。合并后的那列数据内容太多太长了导致提示ACCESS说装不下。

1.   SQL = "CREATE TABLE " & myTable & "([Number] text(50),[Assetment Number] LONGTEXT)"
   

复制代码

像上次那样将第二列改成备注的话代码是改成这个样子吗？

1.     SQL = "CREATE TABLE " & myTable & "([Number] text(50),[Assetment Number] remarks)"

复制代码

好像运行不了。

zhaogang1960

Bettyexcel 发表于 2015-11-26 13:42
谢谢赵版。合并后的那列数据内容太多太长了导致提示ACCESS说装不下。
像上次那样将第二列改成备注的话代 ...

LONGTEXT就是备注型，你可以打开Access看一看，最大长度65535，比文本型大多了

zhaogang1960

如果你已经做好了数据表，请自己修改该字段为备注型

LMY123

For Each tb1 In cat.Tables,E TO A