|
本帖最后由 用心修炼 于 2019-11-3 02:20 编辑
小弟不才,初学VBA几个月,接触了一点ADO的基础知识,本人的工作的也是经常需要把多个工作簿中的多张sheet表汇总在一起(所有sheet中的数据结构一摸一样),用SQL语句写了一段代码,分享出来一起学习,附件中有3个工作簿,一共18张sheet,运行完3秒不到,感觉速度还是不够快,不知道是不是我的电脑配置不行。也请大佬们指点一下,看看有没有地方可以进一步优化,提升代码的运行效率。
Function 数据提取(data_path As String, sht_name()) As Variant
Dim cnn As Object, rst As Object
Dim m&, sql$
Set cnn = CreateObject("adodb.connection")
'用ADO的open方法连接数据源,此处data_path变量是工作簿的完整路径
cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;hdr=yes';data source=" & data_path
'sql语句赋给变量时,变量类型为字符串型,使用union all关键字的目的是将同一工作簿中的多个sheet表的数据汇总在一起
For m = 1 To UBound(sht_name)
sql = sql & " union all " & "select * from [" & sht_name(m) & "$]"
Next
sql = Mid$(sql, 12)
'提交SQL语句,并将结果记录集返回给对象
Set rst = cnn.Execute(sql)
'getrows方法将结果记录集返回给一个variant型变量(通常是数组,下标从0开始,且该数组直接写入单元格时是横向排列)
数据提取 = rst.getrows
cnn.Close
Set cnn = Nothing
End Function
Sub test()
Dim wb_name$, mypath$, wb As Workbook, sht As Worksheet, arr_sht(), brr, crr(1 To 5000, 1 To 6)
Dim sht_count&, i&, j&, x&, y&
j = 0
Const str As String = "总表.xlsm"
Application.ScreenUpdating = False
wb_name = Dir(ThisWorkbook.Path & "\")
Do While Len(wb_name) <> 0
If wb_name <> str Then
Set wb = GetObject(ThisWorkbook.Path & "\" & wb_name)
mypath = wb.FullName
sht_count = wb.Worksheets.Count
ReDim arr_sht(1 To sht_count)
'将工作簿中的所有工作表名称写入数组,作为function函数的第二参数
For Each sht In wb.Worksheets
i = i + 1
arr_sht(i) = sht.Name
Next
wb.Close 0
Set wb = Nothing: Set sht = Nothing
'调用上面的function函数,并将每次循环到的工作簿路径和该工作簿中的所有工作表名作为参数传递给function函数
brr = 数据提取(mypath, arr_sht)
For x = 0 To UBound(brr, 2)
j = j + 1
For y = 0 To 5
crr(j, y + 1) = brr(y, x)
Next
Next
i = 0
End If
wb_name = Dir
Loop
Range("A:A,D:D").NumberFormatLocal = "@"
Range("a1").Resize(1, 6) = [{"月","日","凭证编号","科目编号","科目名称","金额"}]
Range("a2").Resize(j, 6) = crr
Application.ScreenUpdating = True
End Sub
|
|