Код VBA для копирования определенных листов из закрытых рабочих книг, сохраненных в папке, в совершенно новую рабочую книгу

Question

Я надеюсь, что есть способ решить один из очень трудоемких процессов, которые я сейчас выполняю вручную.

Я собираю информацию от более чем 30 человек, которые присылают мне свои достижения (в формате xlsx). До сих пор я открывал каждый файл, находил листы, названные определенным образом (например, искал листы, в названии которых было слово "План"), копировал найденные листы в совершенно новую книгу и сохранял вновь созданную книгу в указанном месте.

Можно ли автоматизировать этот процесс с помощью макроса? В идеале мне нужен макрос, который копирует листы, содержащие "план" в названии листа и не открывая несколько рабочих книг, копирует выбранные рабочие листы, найденные во всех файлах, сохраненных в одной папке, и вставляет эти листы в совершенно новую рабочую книгу. Можно ли этого достичь?

У меня есть код ниже, но когда я запускаю этот макрос, ничего не происходит. Вы видите, что является причиной проблемы?

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

Answer 1

Добавьте приведенные ниже процедуры в новый стандартный модуль и выполните CopyWorkSheets():

После его запуска вы увидите новый файл в папке dest Plans 2017-07-27 07-30.xlsx (по дате)

---

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

---

Ваш исходный код должен вызываться с помощью строки, подобной CopyWorkSheets "D:\Test1\", "FileName.xlsx" но он не перебирает все файлы и не ищет имена листов, содержащие "Планы" в имени.