VBA copy sheets in new workbook and rename them after original file name

[laruna]

Hi all,
I have a folder with four files (e.g. Max, Peter, John, Marc). These workbooks each contain 12 worksheets all named identically (months of the year). Is it possible to have all the sheets named "January" copied from the four files into a new workbook? The sheets in this new workbook should be named after the original file, e.g. worksheet "January" from workbook "Max" is named "Max" in the new workbook. Eventually I want to have 12 new workbooks each containing the sheets Max, Peter, John and Marc.

I tried to put a code together from what I found on the internet. Unfortunately, it does not work and stops after one copied sheet with no renaming.
Any help is appreciated!

Sub test()
   Dim sFolder As String
   Dim sFile As String
   Dim wbSource As Workbook
   Dim wbMaster As Workbook
   
   sFolder = "B:\IT-DL\"    'remember trailing backslash
   'set up the master workbook
   Set wbMaster = ThisWorkbook
   
   On Error GoTo errHandler   'reset application setting on error
   Application.ScreenUpdating = False
   
   'loop through all excel files in folder
   sFile = Dir(sFolder & "*.xls*")
   Do Until sFile = ""
   
      'open the source workbook
      If sFile <> wbMaster.Name Then   'don't process the master workbook
         Set wbSource = Workbooks.Open(sFolder & sFile)
         
         'copy the first worksheet
         wbSource.Worksheets("January").Copy.PasteSpecial xlPasteAllUsingSourceTheme, After:=wbMaster.Sheets(wbMaster.Sheets.Count)
         wbMaster.Worksheets("January").Name = Left(wbSource.Name, Len(wbSource.Name) - 4)
         wbSource.Close SaveChanges:=False
         Application.CutCopyMode = False
      End If
      
      'get the next file
      sFile = Dir()
   Loop
   
   'tidy up
   Set wbSource = Nothing
   Set wbMaster = Nothing
   
errHandler:
   Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

Hi and welcome to MrExcel"

Try this

Put the source files in the "In" folder.
The new files will remain in the "Output" folder.

Update the folder names on these lines:

  sFolderIn = "C:\trabajo\books\"    'remember trailing backslash
  sFolderOutput = "C:\trabajo\out\"

Sub copy_sheets_in_new_workbook()
  Dim sFolderIn As String, sFolderOutput As String, sFile As Variant
  Dim wbSource As Workbook, wb As Workbook, sh As Worksheet
  Dim sName As String, m As String, i As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  sFolderIn = "C:\trabajo\books\"    'remember trailing backslash
  sFolderOutput = "C:\trabajo\out\"
  '
  For i = 1 To 12
    m = MonthName(i)
    Workbooks.Add (xlWBATWorksheet)
    ActiveWorkbook.SaveAs sFolderOutput & m & ".xlsx"
  Next
  '
  sFile = Dir(sFolderIn & "*.xls*")
  Do While sFile <> ""
    Set wbSource = Workbooks.Open(sFolderIn & sFile)
    For Each sh In wbSource.Sheets
      sName = sh.Name
      For Each wb In Workbooks
        If LCase(Left(wb.Name, Len(wb.Name) - 5)) = LCase(sName) Then
          sh.Copy after:=wb.Sheets(wb.Sheets.Count)
          wb.Sheets(wb.Sheets.Count).Name = sName & " From " & Left(sFile, Len(sFile) - 5)
          Exit For
        End If
      Next
    Next
    wbSource.Close False
    sFile = Dir()
  Loop
  '
  For i = 1 To 12
    m = MonthName(i)
    With Workbooks(m)
      If .Sheets.Count > 1 Then
        .Sheets(1).Delete
      End If
      .Close True
    End With
  Next
End Sub

 

[laruna]

It works like a charm! Thank you!
I have a similar task to do with another folder where the worksheets within the workbooks are not named after months. Is there an easy way to adapt the code so that it copies all the first sheets to one new workbook and name it whatever the sheet name was while renaming the copied sheet to the old workbook name? Then go to sheets 2 and so on. It would also be no problem to run the code separately for each worksheet if that makes the code easier.
Can you give me some pointers here as well? Only if not too much of a hassle

 

[DanteAmor]

It seems to be a new thread. Create a new thread and explain there with examples what you need.