ADO将EXCEL导入ACCESS有选择地导入

xd3210 · 发表于 2016-4-12 14:08

Bettyexcel 发表于 2016-4-12 12:56
谢谢赵版。
还有一个问题，发货记录表的标题实际是这样的，更新了附件，别人的标题我没有权力更改，请您 ...

最好是格式、标题都一样，至少是格式要一样，就是说每列对应的数据内容、数据类型是一样的才能用一个查询语句来完成导入操作

zhaogang1960 · 发表于 2016-4-12 14:26

Bettyexcel 发表于 2016-4-12 12:56
谢谢赵版。
还有一个问题，发货记录表的标题实际是这样的，更新了附件，别人的标题我没有权力更改，请您 ...

Sub Macro1()
Dim Fso As Object, File As Object, cnn As Object, SQL$, arr, arrf$(), i&, j&, l&, u&, v&, n&, d As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
ReDim arrf(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count)
For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
      If File.Name Like "发货记录表*.xlsx" Then
         n = n + 1
         arrf(n) = File
      End If
Next
Set d = CreateObject("scripting.dictionary")
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"
For l = n To 1 Step -1
      SQL = "select f1,f7,f5 from [Excel 12.0;hdr=no;Database=" & arrf(l) & ";].[发货$c6:j] WHERE f8='临时'"
      Set rs = cnn.Execute(SQL)
      If Not rs.EOF Then
         arr = rs.GetRows
         For i = 0 To UBound(arr, 2)
            If Not d.Exists(arr(0, i)) Then
                  d(arr(0, i)) = ""
                  SQL = "select * from 临时 where [Order]='" & arr(0, i) & "'"
                  Set rs = CreateObject("adodb.Recordset")
                  rs.Open SQL, cnn, 1, 3
                  If rs.RecordCount = 0 Then
                     rs.AddNew
                     u = u + 1
                  Else
                     v = v + 1
                  End If
                  For j = 0 To rs.Fields.Count - 1
                     rs.Fields(j) = arr(j, i)
                  Next
                  rs.Update
            End If
         Next
      End If
Next
MsgBox "添加" & u & "条记录，更新" & v & "条记录。", vbInformation
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Set Fso = Nothing
End Sub

zhaogang1960 · 发表于 2016-4-12 14:27

请测试附件

发货记录.rar (56.37 KB, 下载次数: 133)

Bettyexcel · 发表于 2016-4-12 14:27

xd3210 发表于 2016-4-12 14:08
最好是格式、标题都一样，至少是格式要一样，就是说每列对应的数据内容、数据类型是一样的才能用一个查询 ...

格式类型是一样的，只是需要把人家的标题按我的来规范。

Bettyexcel · 发表于 2016-4-12 14:46

zhaogang1960 发表于 2016-4-12 14:27
请测试附件

谢谢赵版。有时候文件夹里是没有“发货记录表”的，当文件夹没有此表时，运行后出现了错误提示：
Run time error 424
Object required
想要的结果是，如果文件夹里没有发货记录表时也能顺利运行宏代码。

zhaogang1960 · 发表于 2016-4-12 14:52

本帖最后由 zhaogang1960 于 2016-4-12 14:54 编辑

Bettyexcel 发表于 2016-4-12 14:46
谢谢赵版。有时候文件夹里是没有“发货记录表”的，当文件夹没有此表时，运行后出现了错误提示：
Run ti ...

如果没有“发货”工作表的不是需要的数据源：
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"
下面加一句错误处理语句：
On Error Resume Next

如果数据源工作表名不确定，则需要修改程序，自动识别工作表名

Bettyexcel · 发表于 2016-4-12 15:08

zhaogang1960 发表于 2016-4-12 14:52
如果没有“发货”工作表的不是需要的数据源：
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Sourc ...

非常非常感谢赵版。顺利执行了。强大！！！

xd3210 · 发表于 2016-4-12 15:44

Sub Macro1()
Dim Fso As Object, File As Object, cnn As Object, SQL$, arr, arrf$(), i&, j&, l&, u&, v&, n&, d As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
ReDim arrf(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count)
For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
      If File.Name Like "发货记录表*.xlsx" Then
         n = n + 1
         arrf(n) = File
      End If
Next
Set d = CreateObject("scripting.dictionary")
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;;Data Source=" & ThisWorkbook.Path & "\Database.accdb"
For l = n To 1 Step -1
      SQL = "select f3 as 订单号,f9 as 发货日期,f7 as 发往 from [Excel 12.0;hdr=no;imex=1;Database=" & arrf(l) & ";].[发货$a6:j] WHERE f10='临时'"
      Set rs = cnn.Execute(SQL)
      If Not rs.EOF Then
         arr = rs.GetRows
         For i = 0 To UBound(arr, 2)
            If Not d.Exists(arr(0, i)) Then
                  d(arr(0, i)) = ""
                  SQL = "select * from 临时 where [Order]='" & arr(0, i) & "'"
                  MsgBox SQL
                  Set rs = CreateObject("adodb.Recordset")
                  rs.Open SQL, cnn, 1, 3
                  If rs.RecordCount = 0 Then
                     rs.AddNew
                     u = u + 1
                  Else
                     v = v + 1
                  End If
                  For j = 0 To rs.Fields.Count - 1
                     rs.Fields(j) = arr(j, i)
                  Next
                  rs.Update
            End If
         Next
      End If
Next
MsgBox "添加" & u & "条记录，更新" & v & "条记录。", vbInformation
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Set Fso = Nothing
End Sub

xd3210 · 发表于 2016-4-12 15:48

Sub Macro1()
Dim Fso As Object, File As Object, cnn As Object, SQL$, arr, arrf$(), i&, j&, l&, u&, v&, n&, d As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
ReDim arrf(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count)
For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
      If File.Name Like "发货记录表*.xlsx" Then
         n = n + 1
         arrf(n) = File
      End If
Next
Set d = CreateObject("scripting.dictionary")
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;;Data Source=" & ThisWorkbook.Path & "\Database.accdb"
For l = n To 1 Step -1
      SQL = "select f3 as 订单号,f9 as 发货日期,f7 as 发往 from [Excel 12.0;hdr=no;imex=1;Database=" & arrf(l) & ";].[发货$a6:j] WHERE f10='临时'"
      Set rs = cnn.Execute(SQL)
      If Not rs.EOF Then
         arr = rs.GetRows
         For i = 0 To UBound(arr, 2)
            If Not d.Exists(arr(0, i)) Then
                  d(arr(0, i)) = ""
                  SQL = "select * from 临时 where [Order]='" & arr(0, i) & "'"
                  MsgBox SQL
                  Set rs = CreateObject("adodb.Recordset")
                  rs.Open SQL, cnn, 1, 3
                  If rs.RecordCount = 0 Then
                     rs.AddNew
                     u = u + 1
                  Else
                     v = v + 1
                  End If
                  For j = 0 To rs.Fields.Count - 1
                     rs.Fields(j) = arr(j, i)
                  Next
                  rs.Update
            End If
         Next
      End If
Next
MsgBox "添加" & u & "条记录，更新" & v & "条记录。", vbInformation
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Set Fso = Nothing
End Sub

xd3210 · 发表于 2016-4-12 15:49

Sub Macro1()
Dim Fso As Object, File As Object, cnn As Object, SQL$, arr, arrf$(), i&, j&, l&, u&, v&, n&, d As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
ReDim arrf(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count)
For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
      If File.Name Like "发货记录表*.xlsx" Then
         n = n + 1
         arrf(n) = File
      End If
Next
Set d = CreateObject("scripting.dictionary")
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;;Data Source=" & ThisWorkbook.Path & "\Database.accdb"
For l = n To 1 Step -1
      SQL = "select f3 as 订单号,f9 as 发货日期,f7 as 发往 from [Excel 12.0;hdr=no;imex=1;Database=" & arrf(l) & ";].[发货$a6:j] WHERE f10='临时'"
      Set rs = cnn.Execute(SQL)
      If Not rs.EOF Then
         arr = rs.GetRows
         For i = 0 To UBound(arr, 2)
            If Not d.Exists(arr(0, i)) Then
                  d(arr(0, i)) = ""
                  SQL = "select * from 临时 where [Order]='" & arr(0, i) & "'"
                  MsgBox SQL
                  Set rs = CreateObject("adodb.Recordset")
                  rs.Open SQL, cnn, 1, 3
                  If rs.RecordCount = 0 Then
                     rs.AddNew
                     u = u + 1
                  Else
                     v = v + 1
                  End If
                  For j = 0 To rs.Fields.Count - 1
                     rs.Fields(j) = arr(j, i)
                  Next
                  rs.Update
            End If
         Next
      End If
Next
MsgBox "添加" & u & "条记录，更新" & v & "条记录。", vbInformation
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Set Fso = Nothing
End Sub

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

[求助] ADO将EXCEL导入ACCESS有选择地导入

评分