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