请教：VBA跨工作薄动态取数

zhaogang1960

pppeeerrr 发表于 2014-6-2 14:11
赵老师，您好，已模拟效果，请看附件↓

工作表中有多余的数据，解决办法限制取值区域：A:B：

1. Sub 宏1()
   
2.     Dim cnn As Object, rs As Object, SQL$, arr, i&
   
3.     Dim objWMI As Object
   
4.     Const HKEY_LOCAL_MACHINE = &H80000002
   
5.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
6.     objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 200
   
7.     arr = Sheets("各类列表").[a1].CurrentRegion
   
8.     MyPath = ThisWorkbook.Path & ""
   
9.     Set cnn = CreateObject("adodb.connection")
   
10.     cnn.Open "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source =" & MyPath & arr(1, 3)
    
11.     For i = 1 To UBound(arr)
    
12.         SQL = "select * from [Excel 12.0;imex=1;Database=" & MyPath & arr(i, 3) & ";].[" & arr(2, 2) & "$a:b]"
    
13.         With Sheets(arr(i, 6))
    
14.             .Cells.ClearContents
    
15.             Set rs = cnn.Execute(SQL)
    
16.             For j = 1 To rs.Fields.Count
    
17.                 .Cells(1, j) = rs.Fields(j - 1).Name
    
18.             Next
    
19.             .[a2].CopyFromRecordset rs
    
20.             With .UsedRange
    
21.                 .Value = .Value
    
22.             End With
    
23.         End With
    
24.     Next
    
25.     rs.Close
    
26.     cnn.Close
    
27.     Set rs = Nothing
    
28.     Set cnn = Nothing
    
29. End Sub

复制代码

zhaogang1960

请看附件
VBA跨工作薄动态取数-0602.rar (71.78 KB, 下载次数: 91)

2014-6-2 14:56 上传

点击文件名下载附件

pppeeerrr

zhaogang1960 发表于 2014-6-2 14:57
请看附件

赵老师，谢谢您的耐心回复，已经没有问题了。
对于我在17楼提到的第2点，之前程序是可以把错误值取到的。之前测试时为了方便没有关闭源文件（但文件已经保存），就不能取错误值，关闭源文件后，就可以正常取值了。
这个帖子本来是我的求助帖，但赵老师您的回复比我的还要快好多，真心的再次感谢您！

zd0901

赵老师：请教下，下面是一段汇总当前文件夹及子文件夹下所有EXEXL文件内容的代码，但我测试了下，他只能汇总二列数据，我想要汇总相同工作表名称中所有数据应该怎么修改，谢了！
Public d
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.ClearContents
    Cells(1, 1) = "编号"
    Cells(1, 2) = "数量"
    Set d = CreateObject("scripting.dictionary")
    Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    Application.ScreenUpdating = True
    If d.Count > 0 Then
        ThisWorkbook.Sheets(1).[a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
        ThisWorkbook.Sheets(1).[b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
    End If
End Sub
Sub Getfd(ByVal pth)
   
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
    For Each f In ff.Files
        Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理
        If InStr(Split(f.Name, ".")(UBound(Split(f.Name, "."))), "xl") > 0 Then
            If f.Name <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(f)
                For Each sht In wb.Sheets
                    If WorksheetFunction.CountA(sht.UsedRange) > 1 Then
                        arr = sht.UsedRange
                        For j = 2 To UBound(arr)
                            d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
                        Next j
                    End If
                Next sht
                wb.Close False
            End If
        End If
    Next f
    For Each fd In ff.subfolders
        Getfd (fd)
    Next fd
End Sub

LMY123

SQL = "select * from [Excel 12.0;imex=1;Database=" & MyPath & arr(i, 3) & ";].[" & arr(2, 2) & "$a:b]"