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

Question

I am working on macro that takes the path from clipboard, goes through each folder and subfolder in this path, opens xlsm file in finance subfolder and deletes KPI sheet. Below you can find the folder structure in my path:

P:\\main folder\\project folder\\finance subfolder\\

P:\\main folder\\project folder\\brief subfolder\\

P:\\main folder\\project folder\\production subfolder\\

P:\\main folder\\project folder\\delivery subfolder\\

P:\\main folder\\project folder\\feedback subfolder\\

Basically, I copy "P:\\main folder\\" and my macro goes through all project folders and all subfolders. I want to optimise this process and write a code that goes through all project folders in main folder but then goes only to finance subfolder and looks for xlsm files. I've tried to use the code that was posted here but it works only if I put "P:\\main folder\\project folder\\" path not if I put "P:\\main folder\\" path.

As far as I see the reason is that my macro is looking for finance subfolder not in project folder but in main folder but this is only my guess. Below you can find the code:

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

How can I change a code so it goes through each project folder but then goes only to finance subfolder and omits others?

Answer 1

Here is my idea, but it is done for 2 level subfolder (if I understood the task properly):

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

And it looks like this If it fits - you need to fix it for your solution, it's just a thoughts :)

Update per OPs comment

I've updated code with some more Debug.Print lines Here the file tree that I've created for testing: Each folder has a "Book3.xlsm" file in it. Here is the result of the updated script:

Try to run at least one iteration of project folder and check the immediate window.