search特定工作表的Excel文件以创build一个列表

我已经做了一段时间。 这是我的第一个Excel VBAmacros，我想我几乎在那里。 我似乎无法find一种方法从我的function中获取所需的信息，或者我无法让我的function给我正确的信息。

我需要一个macros，它将通过一个选定的文件夹及其子文件夹来查找具有特定工作表名称的Excel工作簿，然后将这些path输出到一个Excel电子表格中。 目前我的代码将只能find一个文件夹中的文件，否则将不分青红皂白地列出所有的文件。 现在代码有点乱，因为我不确定我需要哪些部分以及哪些部分不需要。

Option Explicit Public ObjFolder As Object Public objFso As Object Public objFldLoop As Object Public lngCounter As Long Public objFl As Object Sub ImportSheet() Dim i As Integer Dim SourceFolder As String Dim FileList As Variant Dim GrabSheet As String Dim FileType As String Dim ActWorkBk As String Dim ImpWorkBk As String Dim NoImport As Boolean Dim FileToWriteTo As Variant Dim xRow As Long Dim xDirect$, xFname$, InitialFoldr$ Dim MyDir As String, myList() 'Startup folder to begin filedialog search InitialFoldr$ = "C:" 'Define filetype FileType = "*.xlsx" 'Define sheetname to copy GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Title:="Specify Sheet Name") 'open dialog for user to select a folder to search With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = Application.DefaultFilePath & "\" .Title = "Please select a folder to list Files from" .InitialFileName = InitialFoldr$ If .Show = True Then MyDir = .SelectedItems(1) End If End With On Error Resume Next myList = SearchFiles(MyDir, "*.xlsx", 0, myList()) If Err = 0 Then 'If user selects folder count the items to search xDirect$ = MyDir & "\" xFname$ = Dir(xDirect$, 8) 'Creates list with filenames FileList = ListFiles(xDirect$ & FileType) 'Imports data Application.ScreenUpdating = False ActWorkBk = ActiveWorkbook.Name NoImport = False 'Clear contents of Active sheet and set active cell to A1 Sheets(1).UsedRange.ClearContents Sheets(1).Select Range("A1").Select For i = 1 To UBound(FileList) 'Opens file Workbooks.Open (xDirect$ & FileList(i)) ImpWorkBk = ActiveWorkbook.Name 'Checks to see if the specific sheet exists in the workbook On Error Resume Next ActiveWorkbook.Sheets(GrabSheet).Select If Err > 0 Then NoImport = True GoTo nxt End If Err.Clear On Error GoTo 0 xFname$ = Dir(xDirect$ & FileList(i)) Do While xFname$ <> "" ThisWorkbook.Activate ActiveCell.Offset(xRow) = xDirect$ & xFname$ xRow = xRow + 1 xFname$ = Dir Loop 'Copies sheet 'ActiveWorkbook.Sheets(GrabSheet).Copy after:=Workbooks(ActWorkBk).Sheets(Workbooks(ActWorkBk).Sheets.Count) 'Renames the imported sheet On Error Resume Next ActiveSheet.Name = "Specs with " & GrabSheet Err.Clear On Error GoTo 0 nxt: 'Closes importfile Workbooks(ImpWorkBk).Activate Application.DisplayAlerts = False ActiveWorkbook.Saved = True ActiveWorkbook.Close SaveChanges:=False Application.DisplayAlerts = True 'Workbooks(ActWorkBk).Activate Next i 'Error if some sheets were not found ' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet Application.ScreenUpdating = True Else MsgBox "No file found" End If On Error GoTo 0 ' End If 'End With 'End Function End Sub 'WITH SUBFOLDERS - Function that creates an array with all the files in the folder Private Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant Dim fso As Object, myFolder As Object, myFile As Object Set fso = CreateObject("Scripting.FileSystemObject") For Each myFile In fso.getfolder(MyDir).Files If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _ * (myFile.Name Like myFileName) Then n = n + 1 ReDim Preserve myList(1 To 2, 1 To n) myList(1, n) = MyDir myList(2, n) = myFile.Name End If Next For Each myFolder In fso.getfolder(MyDir).subfolders SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList) Next SearchFiles = IIf(n > 0, myList, "") End Function 'WITHOUT SUBFOLDERS - Function that creates an array with all the files in the folder Function ListFiles(Source As String) As Variant Dim GetFileNames() As Variant Dim i As Integer Dim FileName As String On Error GoTo ErrHndlr i = 0 FileName = Dir(Source) If FileName = "" Then GoTo ErrHndlr 'Loops until no more mathing files are found Do While FileName <> "" i = i + 1 ReDim Preserve GetFileNames(1 To i) GetFileNames(i) = FileName FileName = Dir() Loop ListFiles = GetFileNames On Error GoTo 0 Exit Function 'If error ErrHndlr: ListFiles = False On Error GoTo 0 End Function 

这将使用“ListFiles”函数给出一个列表。 但我似乎无法弄清楚如何使用“SearchFiles”function列出一个列表。 这最终是我需要做的。

请帮我感觉我好亲近!!!

Answer 1

好吧，我想通了。 我有麻烦的语法来访问我的数组数组。 这里是代码结束了伎俩。

  Option Explicit Public ObjFolder As Object Public objFso As Object Public objFldLoop As Object Public lngCounter As Long Public objFl As Object Sub ImportSheet() Dim i As Integer Dim GrabSheet As String Dim ActWorkBk As String Dim ImpWorkBk As String Dim NoImport As Boolean Dim xRow As Long Dim xFname As String Dim InitialFoldr As String Dim MyDir As String, myList() 'Startup folder to begin filedialog search InitialFoldr = "C:\Users\george.EASYWAY\Desktop\TEST1\" 'Define sheetname to copy GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Default:="snagit", Title:="Specify Sheet Name") 'open dialog for user to select a folder to search With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = Application.DefaultFilePath & "\" .Title = "Please select a folder to list Files from" .InitialFileName = InitialFoldr If .Show = True Then MyDir = .SelectedItems(1) End If End With On Error Resume Next myList = SearchFiles(MyDir, "*.xlsx", 0, myList()) If Err = 0 Then 'Imports data Application.ScreenUpdating = False ActWorkBk = ActiveWorkbook.Name NoImport = False 'Clear contents of Active sheet and set active cell to A1 Sheets(1).UsedRange.ClearContents Sheets(1).Select Range("A1").Select For i = 1 To UBound(myList, 2) 'Opens file Workbooks.Open (myList(1, (i)) & "\" & (myList(2, (i)))) ImpWorkBk = ActiveWorkbook.Name 'Checks to see if the specific sheet exists in the workbook On Error Resume Next ActiveWorkbook.Sheets(GrabSheet).Select If Err > 0 Then NoImport = True GoTo nxt End If Err.Clear On Error GoTo 0 xFname = Dir(myList(1, (i)) & "\" & (myList(2, (i)))) Do While xFname <> "" ThisWorkbook.Activate ActiveCell.Offset(xRow) = (myList(1, (i)) & "\" & (myList(2, (i)))) xRow = xRow + 1 xFname = Dir Loop 'Renames the imported sheet On Error Resume Next ActiveSheet.Name = "Specs with " & GrabSheet Err.Clear On Error GoTo 0 nxt: 'Closes importfile Workbooks(ImpWorkBk).Activate Application.DisplayAlerts = False ActiveWorkbook.Saved = True ActiveWorkbook.Close SaveChanges:=False Application.DisplayAlerts = True 'Workbooks(ActWorkBk).Activate Next i 'Error if some sheets were not found ' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet Application.ScreenUpdating = True Else MsgBox "No file found" End If On Error GoTo 0 End Sub 'Function that creates an array with all the files in the folder with subfolders Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant Dim fso As Object, myFolder As Object, myFile As Object Set fso = CreateObject("Scripting.FileSystemObject") For Each myFile In fso.getfolder(MyDir).Files If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _ * (myFile.Name Like myFileName) Then n = n + 1 ReDim Preserve myList(1 To 2, 1 To n) myList(1, n) = MyDir myList(2, n) = myFile.Name End If Next For Each myFolder In fso.getfolder(MyDir).subfolders SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList) Next SearchFiles = IIf(n > 0, myList, "") End Function