Código VBA para copiar ciertas hojas de libros cerrados guardados en una carpeta a un libro nuevo

Espero que haya una manera de resolver uno de un proceso que consume mucho tiempo y que actualmente realizo manualmente.

Recopila información de más de 30 personas que me enviaron su excel (formato xlsx). Hasta ahora, he estado abriendo cada archivo, localizando las hojas nombradas de cierta manera (por ejemplo, las hojas que contenían la palabra "Plan" en su nombre), copié las hojas encontradas en un libro nuevo y guardé el libro recién creado en una ubicación específica.

¿Se puede automatizar este proceso mediante el uso de macro? Idealmente, me gustaría una macro que copie las hojas que incluyen "plan" en el nombre de la hoja y sin abrir varios libros, copia las hojas de trabajo seleccionadas que se encuentran en todos los archivos guardados en una sola carpeta y pega esas hojas en un libro nuevo. ¿Es esto posible lograr?

Tengo el código de abajo, pero cuando ejecuto esta macro, no pasa nada. ¿Puedes ver lo que está causando el problema?

Sub CopyWorkSheets(strDirectory As String, strSheetName As String)
    Dim xlThisWB As Workbook
    Dim xlWB As Workbook
    Dim xlWS As Worksheet
    Dim strFileName As String
    Dim iCount As Integer

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    On Error Resume Next

    Set xlThisWB = ThisWorkbook
    strFileName = Dir(strDirectory & "*.xlsx")
    Do While strFileName <> ""
        If strFileName <> xlThisWB.Name Then
            With xlThisWB
                Set xlWB = Workbooks.Open(Filename:=strDirectory & strFileName)
                Set xlWS = xlWB.Worksheets(strSheetName)
                xlWS.Copy after:=xlThisWB.Worksheets(xlThisWB.Worksheets.Count)
                xlWB.Close
            End With
        End If
        strFileName = Dir()
    Loop
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

Agregue los procedimientos a continuación en un nuevo módulo estándar y ejecute Copiar hojas de trabajo ():

Después de ejecutarlo, verás un nuevo archivo en la carpeta dest. Plans 2017-07-27 07-30.xlsx (basado en la fecha)

Option Explicit

Public Sub CopyWorkSheets()
    Const PATH_FROM = "D:\Test1\"    '<- Update source folder path
    Const PATH_DEST = "D:\Test2\"    '<- Update destination path

    Dim wb As Workbook, ws As Worksheet, wbResult As Workbook, fName As String, x As String

    If Len(Dir(PATH_FROM, vbDirectory)) > 0 And Len(Dir(PATH_DEST, vbDirectory)) > 0 Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Set wbResult = GetNewWB

        fName = Dir(PATH_FROM & "*.xlsx")
        Do While Len(fName) > 0
            x = PATH_FROM & fName
            Set wb = Workbooks.Open(Filename:=x, UpdateLinks:=False, ReadOnly:=True)
            For Each ws In wb.Worksheets
                If InStr(1, ws.Name, "Plan", vbTextCompare) > 0 Then
                    ws.Copy After:=wbResult.Worksheets(wbResult.Worksheets.Count)
                End If
            Next
            wb.Close SaveChanges:=False
            fName = Dir()
        Loop

        fName = PATH_DEST & "Plans " & Format(Now, "yyyy-mm-dd hh-mm") & ".xlsx"
        SaveNewPlans wbResult, fName
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

Private Function GetNewWB() As Workbook
    Dim wb As Workbook, newSheets As Long

    newSheets = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Set wb = Workbooks.Add
    Application.SheetsInNewWorkbook = newSheets
    Set GetNewWB = wb
End Function

Private Sub SaveNewPlans(ByRef wb As Workbook, ByVal fName As String)
    With Application
        .DisplayAlerts = False
        With wb
            .Worksheets(1).Delete
            .Worksheets(1).Activate
            .SaveAs fName
            .Close SaveChanges:=False
        End With
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Su código inicial debe llamarse con una línea como CopyWorkSheets "D:\Test1\", "FileName.xlsx" pero no itera sobre todos los archivos y no busca nombres de hojas que contengan "Planes" en el nombre