Código VBA para copiar certas planilhas de pastas de trabalho fechadas salvas em uma pasta em uma nova pasta de trabalho

Question

Espero que haja uma forma de resolver um processo muito demorado que atualmente executo manualmente.

Coleciono informações de mais de 30 pessoas que me enviam seu excel (formato xlsx). Até agora, abri cada arquivo, localizando as folhas nomeadas de certa forma (por exemplo, procurei por folhas que continham a palavra "Plan" em seu nome), copiei as folhas para uma nova pasta de trabalho e salvei a pasta de trabalho recém-criada em um local especificado.

Este processo pode ser automatizado através do uso de macro? Idealmente, eu gostaria de uma macro que copie as folhas que incluem "planejar" no nome da planilha e sem abrir várias pastas de trabalho, copie as planilhas selecionadas encontradas em todos os arquivos salvos em uma única pasta e cole essas planilhas em uma nova pasta de trabalho. Isso é possível alcançar?

Eu tenho o código abaixo, mas quando eu executo essa macro, nada acontece. Você consegue ver o que está causando o 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

    

Answer 1

Adicione os procedimentos abaixo em um novo módulo padrão e execute CopyWorkSheets ():

Depois de executá-lo, você verá um novo arquivo na pasta de destino Plans 2017-07-27 07-30.xlsx (com base na data)

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

Seu código inicial deve ser chamado com uma linha como CopyWorkSheets "D:\Test1\", "FileName.xlsx" , mas não itera todos os arquivos e não procura por nomes de planilha contendo "Planos" no nome