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

如何遍历所有SubFolders并获取每个Excel文件的第1行的内容？

2 个答案: