如何使用 VBA 从特定子文件夹打开 xlsm 文件？

Question

我正在处理从剪贴板获取路径的宏，遍历此路径中的每个文件夹和子文件夹，在金融子文件夹中打开 xlsm 文件并删除KPI表。 您可以在下面找到我的路径中的文件夹结构：

P:\\主文件夹\\项目文件夹\\财务子文件夹\\

P:\\主文件夹\\项目文件夹\\简要子文件夹\\

P:\\主文件夹\\项目文件夹\\生产子文件夹\\

P:\\主文件夹\\项目文件夹\\交付子文件夹\\

P:\\主文件夹\\项目文件夹\\反馈子文件夹\\

基本上，我复制“P:\\main folder\\”并且我的宏遍历所有项目文件夹和所有子文件夹。 我想优化此过程并编写一个代码，该代码遍历主文件夹中的所有项目文件夹，然后仅转到财务子文件夹并查找 xlsm 文件。 我尝试使用此处发布的代码，但仅当我放置“P:\\main folder\\project folder\\”路径时才有效，而不是放置“P:\\main folder\\”路径时。

据我所知，原因是我的宏不是在项目文件夹中而是在主文件夹中寻找财务子文件夹，但这只是我的猜测。 您可以在下面找到代码：

Sub test_macro()
Dim oLibrary As Object
Dim srcFolder As Object
Dim folderName As String
Dim clipboard As MSForms.DataObject
Dim CopiedText As String

Set clipboard = New MSForms.DataObject
clipboard.GetFromClipboard
CopiedText = clipboard.GetText

folderName = CopiedText
If StrPtr(folderName) = 0 Then
    Exit Sub
End If

Set oLibrary = CreateObject("Scripting.FileSystemObject")
Merge_Rows oLibrary.GetFolder(folderName)
End Sub

Sub Merge_Rows(srcFolder As Object)

Dim srcSubFolder As Object
Dim srcFile As Object

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

For Each srcSubFolder In srcFolder.SubFolders
    If Split(srcSubFolder, "\")(UBound(Split(srcSubFolder, "\"))) = "1_FINANCE" Then '<-- my guess is that here is the problem but not sure how to fix it
        Merge_Rows srcSubFolder
    End If
Next

For Each srcFile In srcFolder.Files
     If LCase(srcFile.Name) Like "*.xlsm" Then
     Set wbkSource = Workbooks.Open(srcFile)

        On Error Resume Next
        Application.DisplayAlerts = False
        wbkSource.Sheets("KPI").Delete
        Application.DisplayAlerts = True
        wbkSource.Close SaveChanges:=True
    End If
Next
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

如何更改代码，使其通过每个项目文件夹，然后只进入财务子文件夹并忽略其他文件夹？

Answer 1

这是我的想法，但它是为 2 级子文件夹完成的（如果我正确理解了任务）：

Sub Merge_Rows()
Dim srcFolder As Object
Dim srcSubFolder As Object
Dim srcSubSubFolder As Object
Dim srcFile As Object
Dim oLibrary As Object


' This is my testing vars
Dim FolderName As String
FolderName = "P:\"
'''''''''

' will need it as I'm not passing the folder to sub
Set oLibrary = CreateObject("Scripting.FileSystemObject")
Set srcFolder = oLibrary.getfolder(FolderName)

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

' added for testing purposes
Dim fileCounter As Long

    Debug.Print "-----------------" & "Source folder: " & FolderName & "--------------------------------"
    Debug.Print Chr(10)

For Each srcSubFolder In srcFolder.Subfolders ' going to subfolders

    ' print the level 1 subfolder name, which should be a project folder

    For Each srcSubSubFolder In srcSubFolder.Subfolders ' going to sub-subfolder

        ' print the level 2 subfolder name, which should be a project folder subfolder
        Debug.Print "----------- Current SubFolder is: " & FolderName & srcSubFolder.Name & "-----------------"
        If UCase(srcSubSubFolder.Name) Like "*FINANCE*" Then '<--!! put proper pattern
            ' go through it at once
            For Each srcFile In srcSubSubFolder.Files

            Debug.Print "----------------- Current SubSubFolder is: " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name & "---------------------"

                If LCase(srcFile.Name) Like "*.xlsm" Then
                    Debug.Print srcFile.Name
                    fileCounter = fileCounter + 1
                    ' Your code here
                End If
            Next
        End If
        If Not fileCounter = 0 Then
            Debug.Print "There were " & fileCounter & " .xlsm files in " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name
            fileCounter = 0
        Else
            Debug.Print "The search of .xlsm files in " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name & " was not performed"
        End If
        Debug.Print "-----------------" & "End of current SubSubFolder: " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name & "---------------------"
    Next
    Debug.Print "-----------------" & "End current SubFolder: " & FolderName & srcSubFolder.Name & "---------------------"
    Debug.Print Chr(10) & Chr(10)
Next

Debug.Print "<-----------------" & "End Source Folder" & "--------------------->"

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

End Sub

它看起来像这样 如果它适合 - 您需要为您的解决方案修复它，这只是一个想法:)

根据 OP 评论更新

我用更多的Debug.Print行更新了代码 这里是我为测试创建的文件树： 每个文件夹中都有一个“Book3.xlsm”文件。 这是更新脚本的结果：

尝试运行至少一个项目文件夹迭代并检查即时窗口。