Copy data from workbooks in a folder to one master workbook

[jayn309]

Hi. I have data in multiple workbooks in a folder with the same template and I need to extract those circled data into one master workbook as below

I have a code to loop thru all the workbooks in the folder but I do not know how to do the data copying/extracting. Thank you for any help!.

Sub LoopAllFilesInAFolder()

'Loop through all files in a folder
Dim fileName As Variant
fileName = Dir("C:\Users\Student\Documents\6004*")

While fileName <> ""
    
    'Insert the actions to be performed on each file
    
Wend

End Sub

 

[mumps]

Welcome to the Forum. It appears that your templates contain merged cells. You should avoid merging cells because they almost always cause problems for macros. Re-design your templates to unmerge all the merged cells. After you have done this, it would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your template sheet. Alternately, you could upload a copy of your template file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[jayn309]

Welcome to the Forum. It appears that your templates contain merged cells. You should avoid merging cells because they almost always cause problems for macros. Re-design your templates to unmerge all the merged cells. After you have done this, it would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your template sheet. Alternately, you could upload a copy of your template file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

Hi. Thank you for the suggestion but unfortunately I can't unmerged the cells since it's the template I was given to work on and not allow to make any changes on it. I uploaded the template file and the master file on dropbox here: template.xlsx, Master.xlsx

There are multiple excel files have names starting with 6004* in a folder, I need to loop through them and get the value in range D5:D13 of Part Number, Size, Lot Number, Lot #, Quantity in range A5:A13, and value in range P9:P15, O16 of finished, dev, drug, bio, retain, scrap, other, total, in range F9:F16, then copy those value into a row in the Master file.

For the Master file I shared has the data it is supposed to get from the shared template file. Hope this make my question clearer. Thank you.

 

[mumps]

Change the folder path (in red) to suit your needs.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wsSource As Worksheet, wkbSource As Workbook, i As Long, v As Variant, arr() As Variant, cnt As Long
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            Set wsSource = .Sheets(1)
            v = wsSource.Range("D5:D13").Value
            For i = LBound(v) To UBound(v)
                If v(i, 1) <> "" Then
                    cnt = cnt + 1
                    ReDim Preserve arr(1 To cnt)
                    arr(cnt) = v(i, 1)
                End If
            Next i
            With wsDest
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = arr
                .Cells(.Rows.Count, "F").End(xlUp).Offset(1).Resize(, 7).Value = Application.Transpose(wsSource.Range("P9:P15"))
                .Cells(.Rows.Count, "M").End(xlUp).Offset(1).Value = wsSource.Range("O16").Value
            End With
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[jayn309]

Change the folder path (in red) to suit your needs.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wsSource As Worksheet, wkbSource As Workbook, i As Long, v As Variant, arr() As Variant, cnt As Long
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            Set wsSource = .Sheets(1)
            v = wsSource.Range("D5:D13").Value
            For i = LBound(v) To UBound(v)
                If v(i, 1) <> "" Then
                    cnt = cnt + 1
                    ReDim Preserve arr(1 To cnt)
                    arr(cnt) = v(i, 1)
                End If
            Next i
            With wsDest
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = arr
                .Cells(.Rows.Count, "F").End(xlUp).Offset(1).Resize(, 7).Value = Application.Transpose(wsSource.Range("P9:P15"))
                .Cells(.Rows.Count, "M").End(xlUp).Offset(1).Value = wsSource.Range("O16").Value
            End With
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Thank you for your help!!! The code works for value from column F to M in master file which loop through files in folder, but the values from column A to E in master are just the values from the first template file in the folder copy over and over again i.e. the same Part Number abc123 in multiple rows instead of different Part Number from other files. Any idea on how I should fix it?

I also add the code below after Set wsDest = ThisWorkbook.Sheets(1) to clear the master sheet first then do the copy data whenever the code is run. It works when I removed the looping code part but does not work when the looping part is there. Really appreciate your help.

With wsDest
        .Range("A2:M" & .Cells(.Rows.Count, "A").End(xlDown).Row).ClearContents
End With

 

[jayn309]

I add

Debug.Print Join(arr, vbCrLf)

after the arr(cnt)=v(i,1) to check the values and can see that they are printed out correctly in the Immediate windows but does not have those values in the master file somehow.

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wsSource As Worksheet, wkbSource As Workbook, i As Long, v As Variant, arr() As Variant, cnt As Long
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With wsDest
        .Range("A2:M" & .Cells(.Rows.Count, "A").End(xlDown).Row).ClearContents
    End With
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            Set wsSource = .Sheets(1)
            v = wsSource.Range("D5:D13").Value
            For i = LBound(v) To UBound(v)
                If v(i, 1) <> "" Then
                    cnt = cnt + 1
                    ReDim Preserve arr(1 To cnt)
                    arr(cnt) = v(i, 1)
                End If
            Next i
            With wsDest
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = arr
                .Cells(.Rows.Count, "F").End(xlUp).Offset(1).Resize(, 7).Value = Application.Transpose(wsSource.Range("P9:P15"))
                .Cells(.Rows.Count, "M").End(xlUp).Offset(1).Value = wsSource.Range("O16").Value
            End With
            cnt = 0
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[jayn309]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wsSource As Worksheet, wkbSource As Workbook, i As Long, v As Variant, arr() As Variant, cnt As Long
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With wsDest
        .Range("A2:M" & .Cells(.Rows.Count, "A").End(xlDown).Row).ClearContents
    End With
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            Set wsSource = .Sheets(1)
            v = wsSource.Range("D5:D13").Value
            For i = LBound(v) To UBound(v)
                If v(i, 1) <> "" Then
                    cnt = cnt + 1
                    ReDim Preserve arr(1 To cnt)
                    arr(cnt) = v(i, 1)
                End If
            Next i
            With wsDest
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = arr
                .Cells(.Rows.Count, "F").End(xlUp).Offset(1).Resize(, 7).Value = Application.Transpose(wsSource.Range("P9:P15"))
                .Cells(.Rows.Count, "M").End(xlUp).Offset(1).Value = wsSource.Range("O16").Value
            End With
            cnt = 0
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Thank you so much! It works perfectly now.

 

[mumps]

You are very welcome.

 

[jdellasala]

You must not be aware that Power Query is made for this kind of task. You can pull all Excel Workbooks into one query (Get Data From Folder), and combine then into a single worksheet.
Once done, when new Workbooks are added to the folder, all that's needed is to hit Refresh All to update the master Worksheet.