Open multiple workbooks based on cell values and copy and paste information

'WORKBOOKS TO SHEETS
Here's a base macro for collecting data from all files in a specific folder. This version copies the sheet in as a whole.

Workbooks to Sheets - PART 2

The parts of the code that need to be edited are colored to draw your attention.

Yes, you can add a password:

          Set wbData = Workbooks.Open(fPath & fName, Password:="OpenSesame")

This macro is opening every file in a folder. If you need to create a table of workbook names and passwords:

1) That wouldn't be a very "secure" environment... a sheet listing all your passwords is never a good idea.
2) That really would be a different macro.

I also found this code elsewhere works in similar way to Jerry's but it takes copies all worksheets from source workbooks into target workbook.

Same fixes....

How can I amend your code so it works with workbooks with multiple worksheets and copies sheets called i.e. "Source" and this worksheet name will be exactly the same for all workbooks.

Also just for ease of use can I put a reference to a cell for the directory rather than keeping it in the code?

Sub CopyWorksheets()
' Path - modify as needed but keep trailing backslash
  Const sPath = "\\C\Ege\"
  Dim sFile As String
  Dim wbkSource As Workbook
  Dim wSource As Worksheet
  Dim wbkTarget As Workbook
  
  On Error GoTo ErrHandler
  Application.ScreenUpdating = False
  
  Set wbkTarget = ActiveWorkbook
  sFile = Dir(sPath & "*.xlsx*")
  Do While Not sFile = ""
    Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False)
    For Each wSource In wbkSource.Worksheets
      With wbkTarget
        wSource.Copy After:=.Sheets(.Sheets.Count)
      End With
    Next
    wbkSource.Close SaveChanges:=False
    sFile = Dir
  Loop
  
ExitHandler:
  Application.ScreenUpdating = True
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub

I would think these are the edits to make my macro copy only from the SOURCE sheet in each workbook opened:

       'This is the section to customize, what to copy and to where
        'Get name of workbook without extension
            shtAdd = Left(Left(fName, InStr(fName, ".") - 1), 29)
        'Open file
            Set wbData = Workbooks.Open(fPath & fName)
            
        'Rename sheet and copy to target workbook
            wbData.Sheets("Source").Name = shtAdd
            wbData.Sheets(shtAdd).Copy After:=wbkNew.Sheets(wbkNew.Sheets.Count)

Hi Jerry,

Fantastic and thank you very much for your help....

This works like a treat... And while trying to build up this learnt from you too :-)

Just to sum it up for the others who are trying to do something similar .... Hope / Sure this will help others for years.... (Since I started using Excel Forum I find solutions to my problems from posts going back to early 2000s)

... This code will loop through a specified directory in your drive and open all .xlsx files one by one and copy and paste all sheets called "Source" to your master file then close workbooks. And move all the files into a folder called "Imported" ...

1.) Reference to your path is in B12 of Active Worksheet of this workbook. This can be changed
2.) Worksheets to be copied in source workbooks are named "Source" This can be changed

Sub Consolidate_Workbooks()
'Author:     Jerry Beaucaire'
'Date:       6/23/2010     (2007 compatible)
'Summary:    Open all Excel files in a specific folder and copy
'            one sheet from the source files into this master workbook
'            naming sheets for the names of the source workbooks
'            Move imported files into another folder
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long, shtAdd As String, ShtName As Worksheet
Dim wbData As Workbook, wbkNew As Workbook

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
  
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
  
'Path and filename (edit this section to suit)
    fPath = Range("B12").Value           'remember final \ in this string
    fPathDone = fPath & "Imported\"     'remember final \ in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fPath & "*.xlsx")       'listing of desired files, edit filter as desired

'Import data from each found file
    Do While Len(fName) > 0
    'make sure THIS file isn't accidentally reopened
        If fName <> wbkNew.Name Then
        
        'This is the section to customize, what to copy and to where
        'Get name of workbook without extension
            shtAdd = Left(Left(fName, InStr(fName, ".") - 1), 29)
        'Open file
            Set wbData = Workbooks.Open(fPath & fName)
            
        'Rename sheet and copy to target workbook
            wbData.Sheets("Source").Name = shtAdd
            wbData.Sheets(shtAdd).Copy After:=wbkNew.Sheets(wbkNew.Sheets.Count)
           
        'close source file
            wbData.Close False
        'move file to IMPORTED folder
            Name fPath & fName As fPathDone & fName
        'ready next filename, reassert the list since a file was moved
            fName = Dir(fPath & "*.xlsx")
        End If
    Loop

ErrorExit:    'Cleanup
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
End Sub

Link to Original Code is - https://sites.google.com/a/madrocket.../wbs-to-sheets

Warmest Regards,

Egemen