Copy data from multiple files and sheets

[Johnmur]

Hi There,

It’s been a while since I have been on this forum. I have a question that I hope you can help me with.
I have a number of Excel (xlsm) files in a folder. Within each file are a large number of sheets. I need to extract data from each sheet. The worksheet names have the following structure: MonDAY_Prod1, MonDAY_Prod2, MonNGT_Prod1, MonNGT_Prod2 etc.. There can be over 28 sheets in each file. I only need the data from the sheets with the word ‘Prod’ in the Worksheet name.
There can be up to 52 file in the folder and all have the following filename structure: DOC0056423 - Scrap workbook Week 52.xlsm. Each filename is the same except for the week number which will range from 01 to 52. Only the files that I need data from will be in the folder
Within each sheet in each file I need to copy cells Q42:Q62 to a master file for the year. I would like each of the pasted data cols from each worksheet to have the Worksheet name above it. And each of the rows to have the filename in the leftmost cell. Please see the example below.
I’ve found a number of solutions to copy from sheets or files but not something that does multiple files and sheets and pasts in a way that I can track the data.
I hope this is clear enough, please let me know if you need any more detail.

Thank you very much

 

[JLGWhiz]

Assuming the workbook that hosts the code will be in the same folder as your source files,

Sub t()
Dim wb As Workbook, sh As Worksheet, ws As Worksheet, fPath As String, fName As String
Set sh = ActiveSheet
fPath = ThisWorkbook.Path & "\"
fName = Dir(fPath & "*.xlsm")
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
            For Each ws In wb.Sheets
                If InStr(ws.Name, "Prod") > 0 Then
                    If sh.Range("A2") = "" Then
                        sh.Range("A2").Resize(21) = fName
                        sh.Cells("B1") = ws.Name
                        ws.Range("Q42:Q62").Copy sh.Range("B2")
                    Else
                        sh.Cells(Rows.Count, 1).End(xlUp)(2).Resize(21) = fName
                        sh.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = ws.Name
                        ws.Range("AQ42:Q62").Copy sh.Cells(1, Columns.Count).End(xlToLeft)(2)
                    End If
                End If
            Next
        End If
        fName = Dir
    Loop
End Sub

 

[DanteAmor]

Try with this

Create a sheet in the file with the macro with the name "Mater sheet"



Put the file with the macro in the same folder as all the files.

Sub Copy_Multiple_Files()
    'Copy data from multiple files and sheets
    '
    Dim w1 As Workbook, w2 As Workbook
    Dim s1 As Worksheet, s2 As Worksheet
    Dim wFiles As Variant, k As Long, u1 As Long
    
    Application.ScreenUpdating = False
    
    Set w1 = ThisWorkbook
    Set s1 = w1.Sheets("Master sheet")
    s1.Cells.ClearContents
    
    wFiles = Dir(w1.Path & "\" & "*.xls*")
    Do While wFiles <> ""
        If wFiles <> w1.Name Then
            k = 2
            Set w2 = Workbooks.Open(w1.Path & "\" & wFiles)
            u1 = s1.Range("A" & Rows.Count).End(xlUp).Row
            For Each s2 In w2.Sheets
                If InStr(1, LCase(s2.Name), LCase("Prod")) > 0 Then
                    s1.Cells(u1 + 1, k).Value = s2.Name
                    s1.Cells(u1 + 2, k).Resize(21).Value = s2.Range("Q42:Q62").Value
                    s1.Range(s1.Cells(u1 + 2, "A"), s1.Cells(u1 + 2 + 20, "A")).Value = w2.Name
                    k = k + 1
                End If
            Next
            w2.Close False
        End If
        wFiles = Dir()
    Loop
    
    Application.ScreenUpdating = True


    MsgBox "End"
End Sub

 

[Johnmur]

Hi Danteamor,

I loaded in your code and ran it - it seems to be working fine I'll take a good look at it tomorrow just to be sure. Thanks a million

 

[DanteAmor]

You're welcome & thanks for the feedback.