Need help VBA - Copy all worksheets of workbooks in a folder with specific sheet name

[Fable09]

Hi everyone,

Here is the situation:

-All Workbooks are located in the same folder
-Each Workbook may or may not have the Worksheets "April " or "April 2018"
-I want to copy all worksheets with file name "April " or "April 2018" in current Workbooks to new Workbook

Please help me if you know the VBA code

 

[ZVI]

Actually, that error comes from this code line: MsgBox Err.Description, vbCritical, "Error"
Therefore recommendation 2 was not applied. Here is the code with the commented line of errors trapping:

Sub CollectSheetsFromFolder()
 
  ' --> Settings, change to suit
  Const MASK = "April*"
  Const Folder = "D:\MyFolder"
  '<-- End of setings
 
  Dim Arr()
  Dim i As Long, j As Long
  Dim wb As Workbook
  Dim Sh As Worksheet
  Dim FileName As String
 
  ' Create new workbook with single empty sheet
  Set wb = Workbooks.Add(xlWBATWorksheet)
 
  ' Trap errors
  'On Error GoTo exit_  '<-- This should be commented for the debugging
 
  ' Main - collect all MASK like sheets from workbooks in Folder
  Application.ScreenUpdating = False
  FileName = Dir(Folder & "\*.xls*")
  Do While FileName <> ""
    
    Debug.Print Folder & "\" & FileName

    With Workbooks.Open(Folder & "\" & FileName, ReadOnly:=True)
      i = 0
      ReDim Arr(1 To .Sheets.Count)
      For Each Sh In .Worksheets
        If UCase(Sh.Name) Like UCase(MASK) Then
          i = i + 1
          j = j + 1
          Arr(i) = Sh.Name
        End If
      Next
      If i > 0 Then
        ReDim Preserve Arr(1 To i)
        Sheets(Arr).Copy After:=wb.Sheets(wb.Sheets.Count)
      End If
      .Close False
    End With
    FileName = Dir()
  Loop
 
  ' Delete the 1st extra sheet
  If wb.Sheets.Count > 1 Then
    Application.DisplayAlerts = False
    wb.Sheets(1).Delete
    Application.DisplayAlerts = True
  End If
 
exit_:
  
    Application.ScreenUpdating = True
    If Err Then
      MsgBox Err.Description, vbCritical, "Error"
    ElseIf j > 0 Then
      MsgBox "New workbook with " & j & " collected sheet" & IIf(j > 1, "s", "") _
           & " like '" & MASK & "' is created", vbInformation, "Done"
    ElseIf j = 0 Then
      MsgBox "No '" & MASK & "' sheets found", vbExclamation, Folder
    End If
 
End Sub

Close all workbooks of Folder before running the code.
Also please pay attention on what it was mentioned in post #4 :
store workbook with that code out of the Folder.

 

[Fable09]

Hi there,

I used your code and some others found only, it works so well

Sub LoopAllExcelFilesInFolder()'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com


Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim ws As Worksheet
Dim wb1 As Workbook, wb2 As Workbook


Set wb1 = Workbooks.Add






'Optimize Macro Speed
  Application.ScreenUpdating = False


  Application.Calculation = xlCalculationManual


'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)


    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With


'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings


'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"


'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)


'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)


        For Each ws In ActiveWorkbook.Worksheets
    
    If ws.Name Like "Apri*" Then


        ws.Copy after:=wb1.Sheets(wb1.Sheets.Count)




  
      End If
      
      If Not ws.Name Like "Revie*" Then




  
      End If


   
      
Next
  
  
  Workbooks(myFile).Close


  
    'Get next file name
      myFile = Dir


    
  Loop
  
  




'Message Box when tasks are completed




ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


End Sub

Please give a try and add some suggestions.