设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 对象关闭时，不允许操作，运行时错误3704
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 7205|回复: 8

[已解决]对象关闭时，不允许操作，运行时错误3704

[复制链接]
发表于 2013-11-7 23:23 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 张雄友 于 2013-11-8 18:43 编辑

对象关闭时，不允许操作，运行时错误3704
最佳答案
月排行榜 / 总排行榜
hwc2ycy
2013-11-8 08:20
03的格式也能导入呀。
  1. Sub 合并数据()
  2.     Dim cnn As Object, rs As Object
  3.     Dim SQL$, MyFile$, s$, m&, n&, t$, i%, z$, v%
  4.    
  5.     With Application.FileDialog(msoFileDialogFolderPicker)
  6.         .InitialFileName = ThisWorkbook.Path & ""
  7.         If .Show = False Then Exit Sub
  8.         MyPath = .SelectedItems(1) & ""
  9.     End With

  11.     Dim msg As String, nsg As String, BBB As String
  12.     Application.ScreenUpdating = False
  13.     Set cnn = CreateObject("ADODB.Connection")
  14.     Set cat = CreateObject("ADOX.Catalog")
  15.     Cells.ClearContents
  16.     MyFile = Dir(MyPath & "*.xls")
  17.     On Error Resume Next
  18.     Do While MyFile <> ""
  19.         If MyFile <> ThisWorkbook.Name Then
  20.             n = n + 1
  21.             If n = 1 Then
  22.                 cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & MyPath & MyFile & "';Extended Properties='Excel 12.0';"
  23.             Else
  24.                 t = "[Excel 12.0;Database=" & MyPath & MyFile & "]."
  25.             End If
  26.             cat.ActiveConnection = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & MyPath & MyFile & "';Extended Properties='Excel 12.0';"
  27.             For Each tb1 In cat.Tables
  28.                 If tb1.Type = "TABLE" Then
  29.                     z = ""
  30.                     z = tb1.Columns(0).Name
  31.                     If Left$(z, 1) <> "F" Then
  32.                         s = Replace(tb1.Name, "'", "")
  33.                         If Right(s, 1) = "$" Then
  34.                             v = v + 1
  35.                             If v = 1 Then
  36.                                 Set rs = cnn.Execute("[" & s & "]")
  37.                                 For i = 1 To rs.Fields.Count
  38.                                     Cells(1, i) = rs.Fields(i - 1).Name
  39.                                 Next
  40.                             End If
  41.                             m = m + 1
  42.                             If m > 49 Then
  43.                                 Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  44.                                 m = 1
  45.                                 SQL = ""
  46.                             End If
  47.                              If Len(SQL) Then SQL = SQL & " union all "

  49.                             SQL = SQL & "select * from " & t & "[" & s & "] "
  50.                         End If
  51.                     End If
  52.                 End If
  53.             Next
  54.         End If
  55.         MyFile = Dir()
  56.     Loop
  57.     On Error GoTo 0
  58.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  59.     cnn.Close
  60.     Set cnn = Nothing
  61.     Set cat = Nothing
  62.     Set tb1 = Nothing
  63.     Application.ScreenUpdating = True
  64. End Sub
复制代码

合并.rar

179.19 KB, 下载次数: 50
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
 楼主| 发表于 2013-11-8 00:18 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
附件是EXCEL 2010 格式文件，如果换成：

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName

又会提示：未找到提供程序，该程序可以未正确安装。


回复

使用道具 举报

hwc2ycy
发表于 2013-11-8 00:43 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
http://www.connectionstrings.com/excel/
连接字符串就不对。
activeconnection要的是活动连接，而不是连接字符串。
回复

使用道具 举报

 楼主| 发表于 2013-11-8 05:57 | 显示全部楼层
hwc2ycy 发表于 2013-11-8 00:43
http://www.connectionstrings.com/excel/
连接字符串就不对。
activeconnection要的是活动连接，而不是连 ...

怎么改才对？
回复

使用道具 举报

 楼主| 发表于 2013-11-8 06:52 | 显示全部楼层
如果明细中的EXCEL 是03版本就不会出错。
回复

使用道具 举报

 楼主| 发表于 2013-11-8 07:49 | 显示全部楼层
hwc2ycy 发表于 2013-11-8 00:43
http://www.connectionstrings.com/excel/
连接字符串就不对。
activeconnection要的是活动连接，而不是连 ...

难道是03版本的代码在10中就不适用了？
回复

使用道具 举报

hwc2ycy
发表于 2013-11-8 07:59 | 显示全部楼层
Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\myFolder\myExcel2007file.xlsx;
Extended Properties="Excel 12.0 Xml;HDR=YES";
  1. Sub 合并数据()
  2.     Dim cnn As Object, rs As Object
  3.     Dim SQL$, MyFile$, s$, m&, n&, t$, i%, z$, v%
  4.     With Application.FileDialog(msoFileDialogFolderPicker)
  5.         .InitialFileName = ThisWorkbook.Path & ""
  6.         If .Show = False Then Exit Sub
  7.         MyPath = .SelectedItems(1) & ""
  8.     End With
  9.     Dim msg As String, nsg As String, BBB As String
  10.     Application.ScreenUpdating = False
  11.     Set cnn = CreateObject("ADODB.Connection")
  12.     Set cat = CreateObject("ADOX.Catalog")
  13.     Cells.ClearContents
  14.     MyFile = Dir(MyPath & "*.xlsx")
  15.     On Error Resume Next
  16.     Do While MyFile <> ""
  17.         If MyFile <> ThisWorkbook.Name Then
  18.             n = n + 1
  19.             If n = 1 Then
  20.                 'cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
  21.                 cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & MyPath & MyFile & "';Extended Properties='Excel 12.0 Xml';"

  23.             Else
  24.                 t = "[Excel 12.0;Database=" & MyPath & MyFile & "]."
  25.             End If
  26.             cat.ActiveConnection = cnn    '"Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
  27.             For Each tb1 In cat.Tables
  28.                 If tb1.Type = "TABLE" Then
  29.                     z = ""
  30.                     z = tb1.Columns(0).Name
  31.                     If Left$(z, 1) <> "F" Then
  32.                         s = Replace(tb1.Name, "'", "")
  33.                         If Right(s, 1) = "$" Then
  34.                             v = v + 1
  35.                             If v = 1 Then
  36.                                 Set rs = cnn.Execute("[" & s & "]")
  37.                                 For i = 1 To rs.Fields.Count
  38.                                     Cells(1, i) = rs.Fields(i - 1).Name
  39.                                 Next
  40.                             End If
  41.                             m = m + 1
  42.                             If m > 49 Then
  43.                                 Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  44.                                 m = 1
  45.                                 SQL = ""
  46.                             End If
  47.                             If Len(SQL) Then SQL = SQL & " union all "

  49.                             SQL = SQL & "select * from " & t & "[" & s & "] "
  50.                         End If
  51.                     End If
  52.                 End If
  53.             Next
  54.         End If
  55.         MyFile = Dir()
  56.     Loop
  57.     On Error GoTo 0
  58.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  59.     cnn.Close
  60.     Set cnn = Nothing
  61.     Set cat = Nothing
  62.     Set tb1 = Nothing
  63.     Application.ScreenUpdating = True
  64. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-11-8 08:10 | 显示全部楼层
后面的cat.activeconnection是可以用连接串的，我搞错了。
  1. Sub 合并数据()
  2.     Dim cnn As Object, rs As Object
  3.     Dim SQL$, MyFile$, s$, m&, n&, t$, i%, z$, v%
  4.     With Application.FileDialog(msoFileDialogFolderPicker)
  5.         .InitialFileName = ThisWorkbook.Path & ""
  6.         If .Show = False Then Exit Sub
  7.         MyPath = .SelectedItems(1) & ""
  8.     End With
  9.     Dim msg As String, nsg As String, BBB As String
  10.     Application.ScreenUpdating = False
  11.     Set cnn = CreateObject("ADODB.Connection")
  12.     Set cat = CreateObject("ADOX.Catalog")
  13.     Cells.ClearContents
  14.     MyFile = Dir(MyPath & "*.xlsx")
  15.     On Error Resume Next
  16.     Do While MyFile <> ""
  17.         If MyFile <> ThisWorkbook.Name Then
  18.             n = n + 1
  19.             If n = 1 Then
  20.                 'cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
  21.                 cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & MyPath & MyFile & "';Extended Properties='Excel 12.0 Xml';"

  23.             Else
  24.                 t = "[Excel 12.0;Database=" & MyPath & MyFile & "]."
  25.             End If
  26.             cat.ActiveConnection = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & MyPath & MyFile & "';Extended Properties='Excel 12.0 Xml';" '"Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
  27.             For Each tb1 In cat.Tables
  28.                 If tb1.Type = "TABLE" Then
  29.                     z = ""
  30.                     z = tb1.Columns(0).Name
  31.                     If Left$(z, 1) <> "F" Then
  32.                         s = Replace(tb1.Name, "'", "")
  33.                         If Right(s, 1) = "$" Then
  34.                             v = v + 1
  35.                             If v = 1 Then
  36.                                 Set rs = cnn.Execute("[" & s & "]")
  37.                                 For i = 1 To rs.Fields.Count
  38.                                     Cells(1, i) = rs.Fields(i - 1).Name
  39.                                 Next
  40.                             End If
  41.                             m = m + 1
  42.                             If m > 49 Then
  43.                                 Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  44.                                 m = 1
  45.                                 SQL = ""
  46.                             End If
  47.                              If Len(SQL) Then SQL = SQL & " union all "

  49.                             SQL = SQL & "select * from " & t & "[" & s & "] "
  50.                         End If
  51.                     End If
  52.                 End If
  53.             Next
  54.         End If
  55.         MyFile = Dir()
  56.     Loop
  57.     On Error GoTo 0
  58.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  59.     cnn.Close
  60.     Set cnn = Nothing
  61.     Set cat = Nothing
  62.     Set tb1 = Nothing
  63.     Application.ScreenUpdating = True
  64. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-11-8 08:20 | 显示全部楼层    本楼为最佳答案   
03的格式也能导入呀。
  1. Sub 合并数据()
  2.     Dim cnn As Object, rs As Object
  3.     Dim SQL$, MyFile$, s$, m&, n&, t$, i%, z$, v%
  4.    
  5.     With Application.FileDialog(msoFileDialogFolderPicker)
  6.         .InitialFileName = ThisWorkbook.Path & ""
  7.         If .Show = False Then Exit Sub
  8.         MyPath = .SelectedItems(1) & ""
  9.     End With

  11.     Dim msg As String, nsg As String, BBB As String
  12.     Application.ScreenUpdating = False
  13.     Set cnn = CreateObject("ADODB.Connection")
  14.     Set cat = CreateObject("ADOX.Catalog")
  15.     Cells.ClearContents
  16.     MyFile = Dir(MyPath & "*.xls")
  17.     On Error Resume Next
  18.     Do While MyFile <> ""
  19.         If MyFile <> ThisWorkbook.Name Then
  20.             n = n + 1
  21.             If n = 1 Then
  22.                 cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & MyPath & MyFile & "';Extended Properties='Excel 12.0';"
  23.             Else
  24.                 t = "[Excel 12.0;Database=" & MyPath & MyFile & "]."
  25.             End If
  26.             cat.ActiveConnection = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & MyPath & MyFile & "';Extended Properties='Excel 12.0';"
  27.             For Each tb1 In cat.Tables
  28.                 If tb1.Type = "TABLE" Then
  29.                     z = ""
  30.                     z = tb1.Columns(0).Name
  31.                     If Left$(z, 1) <> "F" Then
  32.                         s = Replace(tb1.Name, "'", "")
  33.                         If Right(s, 1) = "$" Then
  34.                             v = v + 1
  35.                             If v = 1 Then
  36.                                 Set rs = cnn.Execute("[" & s & "]")
  37.                                 For i = 1 To rs.Fields.Count
  38.                                     Cells(1, i) = rs.Fields(i - 1).Name
  39.                                 Next
  40.                             End If
  41.                             m = m + 1
  42.                             If m > 49 Then
  43.                                 Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  44.                                 m = 1
  45.                                 SQL = ""
  46.                             End If
  47.                              If Len(SQL) Then SQL = SQL & " union all "

  49.                             SQL = SQL & "select * from " & t & "[" & s & "] "
  50.                         End If
  51.                     End If
  52.                 End If
  53.             Next
  54.         End If
  55.         MyFile = Dir()
  56.     Loop
  57.     On Error GoTo 0
  58.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  59.     cnn.Close
  60.     Set cnn = Nothing
  61.     Set cat = Nothing
  62.     Set tb1 = Nothing
  63.     Application.ScreenUpdating = True
  64. End Sub
复制代码
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-20 02:17 , Processed in 0.401448 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表