如何遍歷所有子文件夾並獲取每個Excel文件的第1行的內容？

Question

我想找出一種方法來打開所有子文件夾中的所有Excel文件，並獲取第1行中所有單元格的所有值以及所有這些單元格的所有格式。我認爲我的代碼非常接近，但我認爲其中一個引用是不正確的，或類似的東西。無論如何，當我運行代碼時，它會打開第一個Excel文件，大約一秒鐘後，一切都會凍結。

Sub GetFolder_Data_Collection() 

Range("A:L").ClearContents 
Range("A1").Value = "Name" 
Range("B1").Value = "Path" 

Dim strPath As String 
strPath = GetFolder 

Dim OBJ As Object, Folder As Object, File As Object 

Set OBJ = CreateObject("Scripting.FileSystemObject") 
Set Folder = OBJ.GetFolder(strPath) 

Call ListFiles(Folder) 

Dim SubFolder As Object 

For Each SubFolder In Folder.SubFolders 
    Call ListFiles(SubFolder) 
    Call GetSubFolders(SubFolder) 
Next SubFolder 

End Sub 

Sub ListFiles(ByRef Folder As Object) 

Dim sht As Worksheet 
Dim LastRow As Long 
Dim cCount As Long 
Dim lngColCount As Long 

Set sht = ThisWorkbook.Worksheets("Sheet1") 

On Error Resume Next 
For Each File In Folder.Files 

LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1 

Set wbSource = Workbooks.Open(Filename:=File) 
Set wsSource = wbSource.Worksheets(1) 
'lngRowCount = wsSource.UsedRange.Rows.Count 
lngColCount = wsSource.UsedRange.Columns.Count 

    For cCount = 1 To lngColCount 
     Range("A" & LastRow).Select 
     ActiveCell = File.Name 
     ActiveCell.Offset(0, 1).Value = File.Path 
     ActiveCell.Offset(0, 2).Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 0), Address:=File.Path, TextToDisplay:=File.Path 
     ActiveCell.Offset(0, 3).Value = File.Worksheets(1).Range(1, lngColCount).Value 
     ActiveCell.Offset(0, 4).Value = File.Worksheets(1).Range(1, lngColCount).Format 
    Next cCount 

Next File 

End Sub 

Sub GetSubFolders(ByRef SubFolder As Object) 

Dim FolderItem As Object 
On Error Resume Next 
For Each FolderItem In SubFolder.SubFolders 
    Call ListFiles(FolderItem) 
    Call GetSubFolders(FolderItem) 
Next FolderItem 

End Sub 

Function GetFolder() As String 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
     .Title = "Select a Folder" 
     .AllowMultiSelect = False 
     .InitialFileName = Application.DefaultFilePath 
     If .Show <> -1 Then GoTo NextCode 
     sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function 

再一次，我想獲得第一行（每個Excel文件）的所有單元格值和這些單元格中的每一個的所有格式。

請幫忙。 謝謝！

Answer 1

我認爲如果您先獲得所有匹配的文件，然後循環遍歷它們，那麼管理該過程會更容易。

輕輕測試：

Sub GetFolder_Data_Collection() 

    Dim colFiles As Collection, c As Range 
    Dim strPath As String, f, sht As Worksheet 
    Dim wbSrc As Workbook, wsSrc As Worksheet 
    Dim rw As Range 

    Set sht = ActiveSheet 

    strPath = GetFolder 

    Set colFiles = GetFileMatches(strPath, "*.xls*", True) 

    With sht 
     .Range("A:L").ClearContents 
     .Range("A1").Resize(1, 5).Value = Array("Name", "Path", "Cell", "Value", "Numberformat") 
     Set rw = .Rows(2) 
    End With 

    For Each f In colFiles 
     Set wbSrc = Workbooks.Open(f) 
     Set wsSrc = wbSrc.Sheets(1) 
     For Each c In wsSrc.Range(wsSrc.Range("a1"), _ 
            wsSrc.Cells(1, Columns.Count).End(xlToLeft)).Cells 

      sht.Hyperlinks.Add Anchor:=rw.Cells(1), Address:=wbSrc.Path, TextToDisplay:=wbSrc.Name 
      rw.Cells(2).Value = wbSrc.Path 
      rw.Cells(3).Value = c.Address(False, False) 
      rw.Cells(4).Value = c.Value 
      rw.Cells(5).Value = c.NumberFormat 
      Set rw = rw.Offset(1, 0) 
     Next c 
     wbSrc.Close False 
    Next f 
End Sub 


'Return a collection of file objects given a starting folder and a file pattern 
' e.g. "*.txt" 
'Pass False for last parameter if don't want to check subfolders 
Function GetFileMatches(startFolder As String, filePattern As String, _ 
        Optional subFolders As Boolean = True) As Collection 

    Dim fso, fldr, f, subFldr 
    Dim colFiles As New Collection 
    Dim colSub As New Collection 

    Set fso = CreateObject("scripting.filesystemobject") 
    colSub.Add startFolder 

    Do While colSub.Count > 0 
     Set fldr = fso.GetFolder(colSub(1)) 
     colSub.Remove 1 

     For Each f In fldr.Files 
      If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f 
     Next f 
     If subFolders Then 
      For Each subFldr In fldr.subFolders 
       colSub.Add subFldr.Path 
      Next subFldr 
     End If 
    Loop 
    Set GetFileMatches = colFiles 
End Function 

Function GetFolder() As String 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
     .Title = "Select a Folder" 
     .AllowMultiSelect = False 
     .InitialFileName = Application.DefaultFilePath 
     If .Show <> -1 Then GoTo NextCode 
     sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function 

Answer 2

它可以這樣做也。

Sub GetFileFromFolder() 
    Dim n   As Long 
    Dim fd As FileDialog 
    Dim strFolder As String 
    Dim colResult As Collection 
    Dim i As Long, k As Long 
    Dim vSplit 
    Dim strFn As String 
    Dim vR() As String 
    Dim p As String 
    Dim Wb As Workbook 
    Dim sht As Worksheet, Ws As Worksheet 
    Dim rng As Range, rngDB As Range 


    Set sht = ThisWorkbook.Worksheets("Sheet1") 

     p = Application.PathSeparator 
     Set fd = Application.FileDialog(msoFileDialogFolderPicker) 
     With fd 
      .Show 
      .InitialView = msoFileDialogViewList 
      .Title = "Select Folder" 
      .AllowMultiSelect = False 
      If .SelectedItems.Count = 0 Then 
      Else 
       strFolder = .SelectedItems(1) 
       Set colResult = SearchFolder(strFolder) 

       i = colResult.Count 
       For k = 1 To i 
        If colResult(k) Like "*.xls*" Then 
         n = n + 1 
         ReDim Preserve vR(1 To 5, 1 To n) 
         Set Wb = Workbooks.Open(colResult(k)) 
         Set Ws = Wb.Worksheets(1) 

         lngColCount = Ws.UsedRange.Columns.Count 

         vSplit = Split(colResult(k), p) 
         strFn = vSplit(UBound(vSplit)) 
         vR(1, n) = strFn 
         vR(2, n) = Left(colResult(k), Len(colResult(k)) - Len(strFn)) 
         vR(3, n) = colResult(k) 
         vR(4, n) = Ws.Cells(1, lngColCount).Value 
         vR(5, n) = Ws.Cells(1, lngColCount).NumberFormat 
         Wb.Close (0) 
        End If 
       Next k 
       With sht 
        .UsedRange.Clear 
        .Range("A1").Value = "Name" 
        .Range("B1").Value = "Path" 
        .Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR) 
        Set rngDB = .Range("c2").Resize(n) 
        For Each rng In rngDB 
         .Hyperlinks.Add Anchor:=rng, Address:=rng.Value 
        Next rng 
        .Columns.AutoFit 
       End With 
      End If 
     End With 
End Sub 
Function SearchFolder(strRoot As String) 
    Dim FS As Object 
    Dim fsFD As Object 
    Dim f As Object 

    Dim colFile As Collection 
    Dim p As String 

    On Error Resume Next 
    p = Application.PathSeparator 
    If Right(strRoot, 1) = p Then 
    Else 
     strRoot = strRoot & p 
    End If 

    Set FS = CreateObject("Scripting.FileSystemObject") 
    Set fsFD = FS.GetFolder(strRoot) 
    Set colFile = New Collection 
    For Each f In fsFD.Files 
     colFile.Add f.Path 
    Next f 

    SearchSubfolder colFile, fsFD 

    Set SearchFolder = colFile 
    Set fsFD = Nothing 
    Set FS = Nothing 
    Set colFile = Nothing 

End Function 
Sub SearchSubfolder(colFile As Collection, objFolder As Object) 
    Dim sbFolder As Object 
    Dim f As Object 
    For Each sbFolder In objFolder.subfolders 
     SearchSubfolder colFile, sbFolder 
     For Each f In sbFolder.Files 
      colFile.Add f.Path 
     Next f 
    Next sbFolder 

End Sub