Question

求一个Excel的VBA2007遍历目录及子目录的程序

1.只要将此EXCEL文件放入某个文件夹，运行后就能将此目录和下级的子目录（有可能是多级子目录）中所有的Excel文件全部找出来，并将文件名逐一复制在sheet1中。
2.我所用的EXCEL文件全部是一个格式，是零件用量表，只有一个sheet表格有数据，名称叫“零件用量清单”，其中A列是数量，B列是名称，找到所有文件后能在sheet2中B列将名称列出来，并将同样名称的零件数量在A列进行统计。例如：找到4个文件，其中有3个用到零件XXX，数量分别是3，5，7，有2个用到零件YYY，数量是10，12，有1个用到零件ZZZ，数量是37,那么运行VBA后sheet2里面就只有一个XXX的名称，但数量是3+5+7=15，只有一个YYY的名称，数量是10+12=22，只有一个ZZZ的名称，数量是37。
3.我用的版本是2007版的，一定要2007能用的。
如果觉得分数低，可以提出来，满意我可以追加分数！

Answer 1

'找的网上的代码，按你的需求修改了一下，你试试吧
'使用前首先需要在在工程中引用对象文件scrrun.dll，单击“工程”，“引用”，然后在“引用”对话框中选中“Microsoft Scripting Runtime”前的复选框，然后单击“确定”。

Dim dict1 As Object, dict2 As Object
Dim fso As Object
Public Sub ListAllFiles()
Dim strpath$, fd As Folder
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
strpath = ThisWorkbook.Path
Set fd = fso.getfolder(strpath)
SearchFiles fd
Sheets(1).Range("A1").Resize(dict2.Count) = Application.Transpose(dict2.items)
Sheets(1).Range("B1").Resize(dict2.Count) = Application.Transpose(dict2.keys)

Sheets(2).Range("A1").Resize(dict1.Count) = Application.Transpose(dict1.items)
Sheets(2).Range("B1").Resize(dict1.Count) = Application.Transpose(dict1.keys)
Set dict1 = Nothing: Set dict2 = Nothing
End Sub
Sub SearchFiles(ByVal fd As Folder)
Dim fl As File, sfd As Folder
For Each fl In fd.Files
If fso.GetExtensionName(fl) = "xlsx" And fso.GetFileName(fl) <> ThisWorkbook.Name Then
' If fso.GetExtensionName(fl) = "xls" And fso.GetFileName(fl) <> ThisWorkbook.Name Then
CountDate fl
End If
Next fl
If fd.subfolders.Count = 0 Then Exit Sub
For Each sfd In fd.subfolders
SearchFiles sfd
Next
End Sub
Sub CountDate(ByVal fl As File)
Dim wbk As Workbook, rng As Range, row1, arr, ii
openfl = fl
Set wbk = Application.Workbooks.Open(openfl, 0, True)
If SheetIsOpen(wbk.Name, "零件用量清单") = True Then
dict2(openfl) = "True"
With Sheets("零件用量清单")
Set rng = .Range("B1048576").End(xlUp)
' Set rng = .Range("B65536").End(xlUp)
arr = .Range("A1", rng.Address)
For ii = 1 To UBound(arr)
If arr(ii, 2) <> "" And IsNumeric(arr(ii, 1)) Then dict1(arr(ii, 2)) = dict1(arr(ii, 2)) + arr(ii, 1)
Next
End With
Else: dict2(openfl) = "False"
End If
wbk.Close (False)
End Sub

Function SheetIsOpen(Wbkname$, shtname$)
Dim shtk As String
On Error Resume Next
Err.Clear
shtk = Workbooks(Wbkname).Sheets(shtname).Name
If Err.Number = 0 Then SheetIsOpen = True Else: SheetIsOpen = False
End Function

追问

运行不过去，提示错误如下，能帮忙解决吗？
另外想问问你，我知道VBA2003有个filesearch命令，VBA2007查找目录下及子目录里所有的文件的命令是哪个？怎么用？谢谢！

Answer 2

可以专门建立一个Excel文件作为统计用文件，并在建一个宏，用VB编一个小程序，就可以啦。