跪求一个简单的功能代码，谢谢

一阵疯

Write a VBA script to do below:

We have several excel files in sub-folders,like "Supplier1","Supplier12", and "Supplier-a2".

And in each excel file, it contains severalsuppliers under Supply Planner name.

Pleasewrite a script VBA to :

1, Get data from those excel files;

2, Output the supplier name list undertheir Supply Planner's name in the same sheet

zhaogang1960

欢迎新会员，请测试：

1. Dim arrf(), mf&
   
2. 
   
3. Sub Macro1()
   
4.     Dim Fso As Object, i&, j&, m&, n&, na$, brr(1 To 60000, 1 To 4)
   
5.     Application.ScreenUpdating = False
   
6.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
7.     sFileType = "*.xls"
   
8.     Call GetFiles(ThisWorkbook.Path, sFileType, Fso)
   
9.     For j = 1 To mf
   
10.         With GetObject(arrf(j))
    
11.             arr = .Sheets(1).Range("a2").CurrentRegion
    
12.             .Close False
    
13.         End With
    
14.         na = arr(1, 2)
    
15.         n = 0
    
16.         For i = 4 To UBound(arr)
    
17.             m = m + 1
    
18.             n = n + 1
    
19.             If n = 1 Then
    
20.                 brr(m, 1) = m
    
21.                 brr(m, 2) = arrf(i)
    
22.             End If
    
23.             brr(m, 3) = na
    
24.             brr(m, 4) = arr(i, 1)
    
25.         Next
    
26.         m = m + 2
    
27.     Next
    
28.     Cells.ClearContents
    
29.     [b1].Resize(m, 4) = brr
    
30.     mf = 0
    
31.     Erase arrf
    
32.     Set Fso = Nothing
    
33.     Application.ScreenUpdating = True
    
34. End Sub
    
35. 
    
36. Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, Fso As Object)
    
37.     Dim Folder As Object
    
38.     Dim SubFolder As Object
    
39.     Dim File As Object
    
40.     Set Folder = Fso.GetFolder(sPath)
    
41.    
    
42.     For Each File In Folder.Files
    
43.         If File.Name Like sFileType Then
    
44.             If File.Name <> ThisWorkbook.Name Then
    
45.                 mf = mf + 1
    
46.                 ReDim Preserve arrf(1 To mf)
    
47.                 arrf(mf) = sPath & "" & File.Name
    
48.             End If
    
49.         End If
    
50.     Next
    
51.     If Folder.SubFolders.Count > 0 Then
    
52.         For Each SubFolder In Folder.SubFolders
    
53.             Call GetFiles(SubFolder.Path, sFileType, Fso)
    
54.         Next
    
55.     End If
    
56.     Set Folder = Nothing
    
57.     Set File = Nothing
    
58.     Set SubFolder = Nothing
    
59. End Sub
    
60. 
    

复制代码

zhaogang1960

请看附件
VBA.rar (36.62 KB, 下载次数: 35)

2012-4-24 23:24 上传

点击文件名下载附件

tjredian

赵版 太牛了吧，我看了眼题目的附件 直接就关了。

zhaogang1960

tjredian 发表于 2012-4-24 23:47
赵版 太牛了吧，我看了眼题目的附件 直接就关了。

不会吧，题目不难，就是英语看不懂，哈哈

zhaogang1960

修改一下，把两个变量放到外面总是不舒服：

1. Sub Macro1()
   
2.     Dim Fso As Object, i&, j&, m&, n&, na$, brr(1 To 60000, 1 To 4)
   
3.     Dim arrf$(), mf&
   
4.     Application.ScreenUpdating = False
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     sFileType = "*.xls"
   
7.     Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arrf, mf)
   
8.     For j = 1 To mf
   
9.         With GetObject(arrf(j))
   
10.             arr = .Sheets(1).Range("a2").CurrentRegion
    
11.             .Close False
    
12.         End With
    
13.         na = arr(1, 2)
    
14.         n = 0
    
15.         For i = 4 To UBound(arr)
    
16.             m = m + 1
    
17.             n = n + 1
    
18.             If n = 1 Then
    
19.                 brr(m, 1) = m
    
20.                 brr(m, 2) = arrf(i)
    
21.             End If
    
22.             brr(m, 3) = na
    
23.             brr(m, 4) = arr(i, 1)
    
24.         Next
    
25.         m = m + 2
    
26.     Next
    
27.     Cells.ClearContents
    
28.     If m Then [b1].Resize(m, 4) = brr
    
29.     Set Fso = Nothing
    
30.     Application.ScreenUpdating = True
    
31. End SubPrivate Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
    
32.     Dim Folder As Object
    
33.     Dim SubFolder As Object
    
34.     Dim File As Object
    
35.     Set Folder = Fso.GetFolder(sPath)
    
36.    
    
37.     For Each File In Folder.Files
    
38.         If File.Name Like sFileType Then
    
39.             If File.Name <> ThisWorkbook.Name Then
    
40.                 mf = mf + 1
    
41.                 ReDim Preserve arrf(1 To mf)
    
42.                 arrf(mf) = sPath & "" & File.Name
    
43.             End If
    
44.         End If
    
45.     Next
    
46.     If Folder.SubFolders.Count > 0 Then
    
47.         For Each SubFolder In Folder.SubFolders
    
48.             Call GetFiles(SubFolder.Path, sFileType, Fso, arrf, mf)
    
49.         Next
    
50.     End If
    
51.     Set Folder = Nothing
    
52.     Set File = Nothing
    
53.     Set SubFolder = Nothing
    
54. End Sub
    

复制代码

一阵疯

zhaogang1960 发表于 2012-4-24 23:24
请看附件

好用，谢谢啦