ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 6459|回复: 21

[推荐] 强烈推荐:数组的地位

[复制链接]

TA的精华主题

TA的得分主题

发表于 2015-11-10 22:38 | 显示全部楼层 |阅读模式
强烈推荐:数组的地位。很多时候别人给你写再好的代码,但不能举一反三的,就等于什么也不会。
有10个工作簿,每个工作簿有100个工作表,每个工作表有10行数据。
=10*100*10=10000行。

非常有用,今天搞到这了,避免痔疮发作。

  1. '郑重声明:
  2. '所有代码由 zhaogang1960 版主版权所有,本人仅以附件数据为例修改测试。

  3. Sub 复制办法() '10.67秒
  4.     Dim Mypath$, MyName$, sh As Worksheet, m&
  5.     Cells.Clear
  6.     tt = Timer
  7.     Application.ScreenUpdating = False
  8.     Mypath = ThisWorkbook.Path & ""
  9.     MyName = Dir(Mypath & "*.xlsx")
  10.     Do While MyName <> ""
  11.         If MyName <> ThisWorkbook.Name Then
  12.             Set wb = Workbooks.Open(Mypath & MyName)
  13.                 For Each sh In wb.Sheets
  14.                     m = m + 1
  15.                     If m < 1 Then '搞了半天,是小于1!!!!!!!!!!!!!!!!!!
  16.                         sh.Range("A4:O4").Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
  17.                     Else
  18.                         sh.Range("A5:O" & sh.Cells(Rows.Count, 1).End(xlUp).Row).Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1)
  19.                     End If
  20.                 Next
  21.             wb.Close False
  22.         End If
  23.         MyName = Dir
  24.     Loop
  25.     Application.ScreenUpdating = True
  26.     MsgBox "用时" & Format(Timer - tt, "0.00") & "秒", 64, "提示"
  27. End Sub

  28. Sub ADO加数组() '5秒
  29.     Cells.ClearContents
  30.     tt = Timer
  31.     Dim cnn As Object, SQL$, Mypath$, MyName$, arr, brr(1 To 20000, 0 To 14), i&, j&, m&
  32.     Application.ScreenUpdating = False
  33.     Mypath = ThisWorkbook.Path & ""
  34.     MyName = Dir(Mypath & "*.xlsx")
  35.     Do While MyName <> ""
  36.         If InStr(MyName, ThisWorkbook.Name) = 0 Then
  37.             Set cnn = CreateObject("ADODB.Connection")
  38.             cnn.Open "Provider=Microsoft.ACE.Oledb.12.0;Extended Properties='Excel 12.0;hdr=NO';Data Source=" & Mypath & MyName
  39.             Set rs = cnn.OpenSchema(20)
  40.             Do Until rs.EOF
  41.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
  42.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
  43.                     If Right(s, 1) = "$" Then
  44.                         SQL = "select * from [" & s & "A5:O] where F1 is not null"
  45.                         arr = cnn.Execute(SQL).GetRows
  46.                         For i = 0 To UBound(arr, 2)
  47.                             m = m + 1
  48.                             For j = 0 To 14
  49.                                 brr(m, j) = arr(j, i)
  50.                             Next
  51.                         Next
  52.                     End If
  53.                 End If
  54.                 rs.MoveNext
  55.             Loop
  56.         End If
  57.         MyName = Dir()
  58.     Loop
  59.     [A2].Resize(m, 15) = brr
  60.     cnn.Close
  61.     Set cnn = Nothing
  62.     Application.ScreenUpdating = True
  63.     MsgBox "用时" & Format(Timer - tt, "0.00") & "秒", 64, "提示"
  64. End Sub

  65. Sub 纯数组() '虽然逐个打开工作簿,但只用了2.72秒。
  66.     Cells.ClearContents
  67.     tt = Timer
  68.     Dim Mypath$, MyName$, arr, brr(1 To 20000, 1 To 15), i&, j&, m&, sh As Worksheet
  69.     Mypath = ThisWorkbook.Path & ""
  70.     MyName = Dir(Mypath & "*.xls")
  71.     Application.ScreenUpdating = False
  72.     Do While MyName <> ""
  73.         If MyName <> ThisWorkbook.Name Then
  74.             With Workbooks.Open(Mypath & MyName)
  75.                 For Each sh In .Sheets
  76.                     arr = sh.[A4].CurrentRegion
  77.                     For i = 2 To UBound(arr)
  78.                         If Len(arr(i, 1)) Then
  79.                             m = m + 1
  80.                             For j = 1 To 15
  81.                                 brr(m, j) = arr(i, j)
  82.                             Next
  83.                         End If
  84.                     Next
  85.                 Next
  86.             .Close False
  87.             End With
  88.         End If
  89.         MyName = Dir
  90.     Loop
  91.     [A2].Resize(m, 15) = brr
  92.     Application.ScreenUpdating = True
  93.     MsgBox "用时" & Format(Timer - tt, "0.00") & "秒", 64, "提示"
  94. End Sub

  95. Sub ADO联合查询() '9.92秒
  96.     Dim cnn As Object, rs As Object, SQL$, Mypath$, MyFile$, m&, s$, r&
  97.     Cells.ClearContents
  98.     tt = Timer
  99.     Application.ScreenUpdating = False
  100.     Mypath = ThisWorkbook.Path & ""
  101.     MyName = Dir(Mypath & "*.xlsx")
  102.     Do While MyName <> ""
  103.         If InStr(MyName, ThisWorkbook.Name) = 0 Then
  104.             Set cnn = CreateObject("ADODB.Connection")
  105.             cnn.Open "Provider=Microsoft.ACE.Oledb.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyName
  106.             Set rs = cnn.OpenSchema(20)
  107.             Do Until rs.EOF
  108.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
  109.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
  110.                     If Right(s, 1) = "$" Then
  111.                         m = m + 1
  112.                         If m > 49 Then
  113.                             Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  114.                             m = 1
  115.                             SQL = ""
  116.                         End If
  117.                         If Len(SQL) Then SQL = SQL & " union all "
  118.                         SQL = SQL & "select * from [Excel 12.0;hdr=no;Database=" & Mypath & MyName & "].[" & s & "A5:O] where F1 is not null"
  119.                     End If
  120.                 End If
  121.                 rs.MoveNext
  122.             Loop
  123.         End If
  124.         MyName = Dir()
  125.     Loop
  126.     If Len(SQL) Then Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
  127.     rs.Close
  128.     cnn.Close
  129.     Set rs = Nothing
  130.     Set cnn = Nothing
  131.     Application.ScreenUpdating = True
  132.     MsgBox "用时" & Format(Timer - tt, "0.00") & "秒", 64, "提示"
  133. End Sub
复制代码


复制数据.rar

1.25 MB, 下载次数: 413

TA的精华主题

TA的得分主题

发表于 2015-11-10 22:44 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-11-10 23:05 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
小花鹿 发表于 2015-11-10 22:44
每个工作簿有100个工作表
没见过

这样的数据结构确实是有问题的,但论坛上常有这样的烂事要收拾

TA的精华主题

TA的得分主题

发表于 2015-11-10 23:28 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
数组的确历害,慢慢领会学习!!!

TA的精华主题

TA的得分主题

发表于 2015-11-10 23:39 | 显示全部楼层
楼主举例不恰当
ADO处理多文件主要体现在没有Open过程,相对于处理1000个工作表来说,打开(Open)10个工作簿所用时间可以忽略,在不考虑打开工作簿使用时间情况下,ADO处理数据与数组相比速度要慢近一个数量级,肯定比不了数组速度快,如果每个工作簿有10个工作表,共有100个工作簿测试,《ADO加数组》法比《纯数组》快很多:

复制数据.rar (1.81 MB, 下载次数: 176)

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-11-11 06:15 | 显示全部楼层
zhaogang1960 发表于 2015-11-10 23:39
楼主举例不恰当
ADO处理多文件主要体现在没有Open过程,相对于处理1000个工作表来说,打开(Open)10个工作 ...

嗯,也要看是工作簿多还是工作表多的。《ADO加数组》利用“ADO”不打开,“数组”处理数据,二合为一。

TA的精华主题

TA的得分主题

发表于 2015-11-11 07:56 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
呵呵呵呵呵呵  居然这次发帖不是提问 也是稀奇啊  

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-11-11 08:02 | 显示全部楼层
百度不到去谷歌 发表于 2015-11-11 07:56
呵呵呵呵呵呵  居然这次发帖不是提问 也是稀奇啊

第四种ADO联合联合查询速度还可以快一些,if m > 49 then 拖慢了速度。上班先!

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-11-11 08:04 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
第四种ADO联合联合查询速度还可以快一些,if m > 49 then 拖慢了速度。上班先!

TA的精华主题

TA的得分主题

发表于 2015-11-11 08:26 | 显示全部楼层
百年遇不到这样的事情,这么搞的数据,不弄个ERP咋搞下去呢......
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 05:21 , Processed in 0.051698 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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