Question

已解决： 修复了扫描 C:\ 的问题 -

这实际上是由定义 FolderPath 的代码引起的，它是使用 Range("L4").Value 提取的，但应该是

ThisWorkbook.Sheets("Database").Range("L4").Value

所以下面的代码实际上没有任何问题。很抱歉没有给你所有完整的信息！

我正在尝试编写一些 VBA 代码来执行以下操作：

查找指定路径和子目录中的所有 *.xlsx 和 *.xlsm 文件
以只读方式打开每一个
将内容复制到当前电子表格，然后关闭文件
遍历所有文件

而我目前正在为此而发疯。我能得到的最接近的是从 code that was posted here a while back 派生的，如下所示（其中 FolderPath 只是 "C:\Path\To\Folder\"）：

Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder(FolderPath)
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        For Each oFile In oFolder.Files
            Length = InStrRev(oFile, "\")
            oFileWB = Right(oFile, Len(oFile) - Length)
                'Open the given .xls* file read-only and suppress link update prompt
                Workbooks.Open FileName:=oFile, ReadOnly:=True, UpdateLinks:=False
                'Get current first empty row of database as first target row
                ftr = ThisWorkbook.Worksheets("Database").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                'Copy range from target sheet, from hardcoded cell A7 to AE in the bottom-most occupied row
                Workbooks(oFileWB).Sheets("Target Sheet").Range("A7:AE" & Workbooks(oFileWB).Sheets("Target Sheet").Cells(Rows.Count, 1).End(xlUp).Row).Copy
                'Paste above range into the first empty cell of the database
                ThisWorkbook.Worksheets("Database").Range(ThisWorkbook.Worksheets("Database").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Address).PasteSpecial xlPasteValues
                'Get last row of current database after copying data
                ltr = ThisWorkbook.Worksheets("Database").Cells(Rows.Count, 1).End(xlUp).Row
                'Copy date and filepath of sheet into all rows
                ThisWorkbook.Worksheets("Database").Range("AF" & ftr & ":AF" & ltr).Value = Now()
                ThisWorkbook.Worksheets("Database").Range("AG" & ftr & ":AG" & ltr).Value = oFile
            'Close current file and suppress save changes prompt
            Workbooks(oFileWB).Close savechanges:=False
    Next oFile
    Loop

当这些目录中没有打开任何内容时，这非常有效。但是当这些目录中的一个文件被锁定时，它会崩溃并开始扫描 "C:\" 中的文件而不是 "C:\Path\To\Folder\" 中的文件。然后这会给出权限错误，因为它试图打开 hiberfile.sys。这对我来说是一个相当关键的问题，因为这个脚本 (a) 需要以完全只读的方式运行，并且 (b) 这些目录中的任何文件都可能在任何给定时间被锁定。

有人知道我该如何解决这个问题吗？还有一个较小的问题 - 知道如何限制它打开 *.xlsx 和 *.xlsm 文件，因为目前它试图打开这些目录中的所有内容吗？

提前致谢

Answer 1

已解决：修复了扫描 C:\ 的问题 -

这实际上是由定义 FolderPath 的代码引起的，该代码是使用 Range("L4").Value 提取的，但应该是

ThisWorkbook.Sheets("Database").范围("L4").值

所以下面的代码实际上没有任何问题。很抱歉没有给你所有完整的信息！

指定 .xls 文件的问题已使用 Tim 在上述评论中提供的想法解决。

遍历子目录并打开这些目录中的文件

Traverse subdirectories and open files in those directories

excel

vba

subdirectory

traversal