我已经研究了一段时间了。这是我的第一个Excel VBA宏，我想我差不多了。我似乎无法找到从我的函数中获取所需信息的方法，或者我无法通过函数向我提供正确的信息。
我需要一个宏来搜索选定的文件夹及其子文件夹，以查找包含特定工作表名称的excel工作簿，然后将路径放到Excel电子表格中。目前我的代码要么只找到单个文件夹中的文件，要么会不加选择地列出所有文件。现在代码有点乱，因为我不确定我需要哪些部分以及哪些部分不需要。
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”功能将其列出一个列表。最终，这是我需要做的事情。
请帮助我觉得我太近了!!!
答案 0 :(得分：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