文件数据读取问题

tokem

zhaogang1960 发表于 2014-3-25 23:17
ADO法请参考：

还是请你帮忙一下啦.
在Temp EXCEL文档中建立VBA程序，在performance EXCEL文档中输出如该文档格式的数据，源数据在Wizard文档中。如何实现呢？ Temp.rar (31.96 KB, 下载次数: 2)

2014-3-26 22:27 上传

点击文件名下载附件

zhaogang1960

1. Sub Macro1()
   
2.     Dim cnn As Object, SQL$, MyPath$, MyFile$, n%, arr, brr(1 To 60000, 2 To 8), i&, c, d As Object, wb As Workbook
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\Performance.xls")
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     arr = wb.Sheets("Template").[a18].CurrentRegion
   
8.     For i = 3 To UBound(arr, 2) Step 2
   
9.         If Len(arr(1, i)) Then d(arr(1, i)) = i
   
10.     Next
    
11.     MyPath = ThisWorkbook.Path & "\Wizard"
    
12.     MyFile = Dir(MyPath & "*.xls")
    
13.     Do While MyFile <> ""
    
14.         If MyFile <> ThisWorkbook.Name Then
    
15.             n = n + 1
    
16.             brr(n, 2) = Replace(MyFile, ".xls", "")
    
17.             If n = 1 Then
    
18.                 Set cnn = CreateObject("adodb.connection")
    
19.                 cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='excel 8.0;hdr=no';Data Source=" & MyPath & MyFile
    
20.                 SQL = "select * from [report$a43:o47]"
    
21.             Else
    
22.                 SQL = "select * from [Excel 8.0;hdr=no;Database=" & MyPath & MyFile & ";].[report$a43:o47]"
    
23.             End If
    
24.             arr = cnn.Execute(SQL).GetRows
    
25.             brr(n, 2) = Replace(MyFile, ".xls", "")
    
26.             For i = 1 To UBound(arr)
    
27.                 If Not IsNull(arr(i, 0)) Then
    
28.                     c = d(arr(i, 0))
    
29.                     If c <> "" Then
    
30.                         brr(n, c) = arr(i, 1)
    
31.                         brr(n, c + 1) = arr(i, 2)
    
32.                     End If
    
33.                 End If
    
34.             Next
    
35.         End If
    
36.         MyFile = Dir()
    
37.     Loop
    
38.     wb.Sheets("Template").Range("B21:H45").ClearContents
    
39.     wb.Sheets("Template").[b21].Resize(n, 7) = brr
    
40.     wb.Close True
    
41.     cnn.Close
    
42.     Set cnn = Nothing
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "ok"
    
45. End Sub
    

复制代码

zhaogang1960

请看附件
Temp.rar (36.09 KB, 下载次数: 9)

2014-3-26 22:57 上传

点击文件名下载附件

tokem

zhaogang1960 发表于 2014-3-26 22:57

谢谢高手的耐心解答！
程序中有很多不懂的地方，主要是以下几个：
１）07-10行的作用是什么？arr变量的两个纬度的下角标都是从０开始的吗？
２）变量ｄ的作用是？
３）最主要是２６－３４行的接释？

zhaogang1960

tokem 发表于 2014-3-27 07:07
谢谢高手的耐心解答！
程序中有很多不懂的地方，主要是以下几个：
１）07-10行的作用是什么？arr变量的 ...

程序使用了ADO、字典和数组知识，建议学习一下这些知识：

1. Sub Macro1()
   
2.     Dim cnn As Object, SQL$, MyPath$, MyFile$, n%, arr, brr(1 To 60000, 2 To 8), i&, c, d As Object, wb As Workbook
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\Performance.xls")
   
6.     Set d = CreateObject("scripting.dictionary") '创建字典对象
   
7.     arr = wb.Sheets("Template").[a18].CurrentRegion 'Template表a18的当前区域值写入数组
   
8.     For i = 3 To UBound(arr, 2) Step 2 '逐列，步长2
   
9.         If Len(arr(1, i)) Then d(arr(1, i)) = i '如果有值则添加到字典键值，列号添加到字典条目
   
10.     Next
    
11.     MyPath = ThisWorkbook.Path & "\Wizard"
    
12.     MyFile = Dir(MyPath & "*.xls")
    
13.     Do While MyFile <> ""
    
14.         If MyFile <> ThisWorkbook.Name Then
    
15.             n = n + 1
    
16.             brr(n, 2) = Replace(MyFile, ".xls", "")
    
17.             If n = 1 Then
    
18.                 Set cnn = CreateObject("adodb.connection")
    
19.                 cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='excel 8.0;hdr=no';Data Source=" & MyPath & MyFile
    
20.                 SQL = "select * from [report$a43:o47]"
    
21.             Else
    
22.                 SQL = "select * from [Excel 8.0;hdr=no;Database=" & MyPath & MyFile & ";].[report$a43:o47]"
    
23.             End If
    
24.             arr = cnn.Execute(SQL).GetRows
    
25.             brr(n, 2) = Replace(MyFile, ".xls", "")
    
26.             For i = 1 To UBound(arr) '逐列
    
27.                 If Not IsNull(arr(i, 0)) Then '如果该值不为空
    
28.                     c = d(arr(i, 0)) '字典键值赋值给变量c
    
29.                     If c <> "" Then '如果c不是空串，c就是字典储存的列号,
    
30.                         brr(n, c) = arr(i, 1) '该列号赋值
    
31.                         brr(n, c + 1) = arr(i, 2) '该列号右边一列赋值
    
32.                     End If
    
33.                 End If
    
34.             Next
    
35.         End If
    
36.         MyFile = Dir()
    
37.     Loop
    
38.     wb.Sheets("Template").Range("B21:H45").ClearContents
    
39.     wb.Sheets("Template").[b21].Resize(n, 7) = brr
    
40.     wb.Close True
    
41.     cnn.Close
    
42.     Set cnn = Nothing
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "ok"
    
45. End Sub
    

复制代码

tokem

zhaogang1960 发表于 2014-3-26 22:58
请看附件

谢谢。运行之后，结果好像抓取的数据不对啊。

tokem

zhaogang1960 发表于 2014-3-27 10:54
程序使用了ADO、字典和数组知识，建议学习一下这些知识：

在你的帮助下，问题已得到解决。

LMY123

arr = cnn.Execute(SQL).GetRows