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]

Hi,
Try this for the active workbook:

Sub CopyAprilSheets()
  Dim Arr(), i As Long, Sh As Worksheet
  ReDim Arr(1 To 1000)
  For Each Sh In ActiveWorkbook.Worksheets
    If UCase(Sh.Name) Like "APRIL*" Then
      i = i + 1
      Arr(i) = Sh.Name
    End If
  Next
  If i > 0 Then
    ReDim Preserve Arr(1 To i)
    Sheets(Arr).Copy
    MsgBox "New workbook with " & i & " sheet(s) is created", vbInformation
  Else
    MsgBox "No 'April*' sheets found", vbExclamation
  End If
End Sub

If you want to add "April*" like sheets from other workbook please take into the account that Excel can't store sheets with the same name in one workbook.
Let me know if you able to loop workbooks in a folder or not.

 

[Fable09]

Hi ZVI,

Your code works well with Active workbook only.

Please help me with all Workbooks in a given folder. Some may not have the "April " or "April 2018" Sheet and the code should be able to check and ignore those Workbooks.

Also these Workbooks should be copied to the new created Workbook with the name after such as "April ","April 2018","April 2018(1)","April 2018(2)" to avoid conflict.

Thanks,

 

[ZVI]

Here it is, just write correct mask and folder to the constants MASK and Folder.
And store workbook with that code out of the Folder.

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_
 
  ' Main - collect all MASK like sheets from workbooks in Folder
  Application.ScreenUpdating = False
  FileName = Dir(Folder & "\*.xls*")
  Do While 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

Regards

 

[Fable09]

I replaced D:\MyFolder with my folder and run the code.

It said "Automation error", please advise.

 

[ZVI]

1. Do not use path separator symbol at the end of the folder string.
If possible post your Const Folder value.

2. Comment this line of the code: 'On Error GoTo exit_
and run. On which code line the debugger stops with highlighting?

 

[Fable09]

1. I dont end the folder link with \

2. It just a general message no highlight on code

https://cdn.discordapp.com/attachments/442899868864741388/446136998885982227/unknown.png

 

[ZVI]

2. It just a general message no highlight on code

Error message in Excel has caption with Excel in it, but there is no such caption in your snapshot - not sure where it comes from.

3. In VBE - Tools - References unselect any items started with MISSING: if present
4. Try VBE - Debug - Compile Project to validate the code.

Just for the case, here is instruction how to copy the code:
A. Copy the code
B. In sheet press Alt-F11 to open VBE
C. In VBE choose menu Insert - Module
D. Paste the code
E. Press Alt-Q to close VBE
F. Press Alt-F8 and run the macro CollectSheetsFromFolder

BTW, my code was tested successfully on my side

 

[Fable09]

Hi there,

I follow the procedures still got the same error, it 's from Excel

https://cdn.discordapp.com/attachments/442899868864741388/446143414522871830/unknown.png

Most of the results from Google shows it should have the line Run time error ### but in this case it doesn't have

 

[ZVI]

What about 4?

5. Put cursor into the code and press F8 for step debugging till error happens. Which code line causes that error?
6. Close Excel, open it and try to copy the exact code into the new workbook. Temporary create folder D:\MyFolder and populate it with some workbooks. Then run the code/

You may send me your workbook via email for analysis - PM me your email for further responds.