"找的網上的程式碼，按你的需求修改了一下，你試試吧 "使用前首先需要在在工程中引用物件檔案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