VBA Loop through files in folder and copy/paste variable range to master file

Question

I have been searching for awhile now trying to find a solution, i can find similar solutions but i cannot get any to work even with tweaks and amendments.

I have a master workbook called 'Master.xlsb' with 1 sheet called 'Summary'. I have a list of 189 files in one folder called 'EmailAttachments'.

Each individual file will have a different amount of rows so i would like to loop through all files and copy from range '"B7:B" & LastRow' and paste data below last row containing data in 'Master.xlsb' (Which will increase as data is pasted in).

Also, I would like to have the file name in column A starting from '"A7"' so i know which file the data is from.

Thanks in advance.

EDIT:

I managed to get the code working below:

Public Sub DataToSummary()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRowMaster As Long
Dim DataRowsMaster As Long
Dim LastRowSource As Long
Dim FileNameSource As String
Dim i As Integer, intValueToFind As Integer

Path = "C:\Example\Path\"
Filename = Dir(Path & "*.xlsx")

 Do While Len(Filename) > 0
    Set wbk = Workbooks.Open(Path & Filename)
                For i = 1 To 500
                If Cells(i, 1).Value = intValueToFind Then
                    GoTo Skip
                End If
                Next i
            LastRowSource = Cells(Rows.Count, 2).End(xlUp).Row
            DataRowsSource = LastRowSource - 6
            FileNameSource = Left(Filename, Len(Filename) - 5)
            Workbooks(Filename).Sheets(1).Range("B7:M" & LastRowSource).Copy

            Workbooks("Master.xlsb").Activate
            LastRowMaster = Cells(Rows.Count, 6).End(xlUp).Row
            ThisWorkbook.Sheets(1).Range("F" & LastRowMaster + 1).PasteSpecial xlPasteValues
            ThisWorkbook.Sheets(1).Range("B" & LastRowMaster + 1 & ":B" & LastRowMaster + DataRowsSource).Value = FileNameSource
            ThisWorkbook.Sheets(1).Range("C1:E1").Copy
            ThisWorkbook.Sheets(1).Range("C" & LastRowMaster + 1 & ":E" & LastRowMaster + DataRowsSource).PasteSpecial xlPasteFormulas
Skip:
    wbk.Close True
    Filename = Dir
Loop
End Sub

Can you [edit](https://stackoverflow.com/posts/54252626/edit) your question with the code you have tried, with the "tweaks and amendments", and describe what errors/problems you have with it? Otherwise this question is too broad. For more reference, please see: [Why is “Can someone help me?” not an actual question?](http://meta.stackoverflow.com/q/284236) — BigBen, Jan 18 '19 at 11:07
Appologies, I am new to StackOverflow. I have added the code that worked after a lot of searching, trial and error. I have added the code that worked now and in future will add code i have tried and explain what issues i am having with it. — Andrew Whitty, Jan 31 '19 at 17:14
No problem, glad you resolved your problem. You can actually add your working code as an answer - see [Can I answer my own question](https://stackoverflow.com/help/self-answer). That way it's easy to see the question is resolved. — BigBen, Jan 31 '19 at 18:33

score 1 · Answer 1 · answered Jan 18 '19 at 14:54

Here I found a nice code by user benmichae2. for looping through files in folder Loop through files in a folder using VBA?

Reusing his/her code I would do something like this:

Option Explicit

Sub LoopThroughFiles()

Dim firstEmptyRow As Long
Dim attachmentFolder As String, StrFile As String, filenameCriteria As String
Dim attachmentWorkBook As Workbook
Dim copyRngToArray As Variant

'# Define folder with attachments and set file extension
attachmentFolder = "C:\temp"
filenameCriteria = "xlsx"

'set
StrFile = Dir(attachmentFolder & "\*" & filenameCriteria)
Do While Len(StrFile) > 0
    Set attachmentWorkBook = Workbooks.Open(StrFile)

    With attachmentWorkBook.Worksheets(1)
        '#Copy the first column to array starting from "A7" to End of column
         copyRngToArray = .Range("A7:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With

    '#Thisworkbook is the file where this code is in actually your Master.xlsb file
    With ThisWorkbook.Worksheets(1)
        '#firsEmptyRow returns the first empty row in column B
        firstEmptyRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
        '#paste file name to Column A
        .Range("A" & firstEmptyRow) = StrFile
        '#paste data in column B
        .Range("B" & firstEmptyRow).Resize(UBound(copyRngToArray)) = copyRngToArray
    End With

    Set attachmentWorkBook = Nothing
    StrFile = Dir
Loop

End Sub

Paste this code in a module and check with some example excel files

I haven't tried the code above sorry as i found a solution and have added it to my question as an edit. But I would like to thank you for your response though and for taking the time to look into this for me, greatly appreciated. — Andrew Whitty, Jan 31 '19 at 17:16

score 0 · Accepted Answer · answered Feb 01 '19 at 07:59

Below code has worked for me (Change example path):

Public Sub DataToSummary()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRowMaster As Long
Dim DataRowsMaster As Long
Dim LastRowSource As Long
Dim FileNameSource As String
Dim i As Integer, intValueToFind As Integer

Path = "C:\Example\Path\"
Filename = Dir(Path & "*.xlsx")

 Do While Len(Filename) > 0
    Set wbk = Workbooks.Open(Path & Filename)
                For i = 1 To 500
                If Cells(i, 1).Value = intValueToFind Then
                    GoTo Skip
                End If
                Next i
            LastRowSource = Cells(Rows.Count, 2).End(xlUp).Row
            DataRowsSource = LastRowSource - 6
            FileNameSource = Left(Filename, Len(Filename) - 5)
            Workbooks(Filename).Sheets(1).Range("B7:M" & LastRowSource).Copy

            Workbooks("Master.xlsb").Activate
            LastRowMaster = Cells(Rows.Count, 6).End(xlUp).Row
            ThisWorkbook.Sheets(1).Range("F" & LastRowMaster + 1).PasteSpecial xlPasteValues
            ThisWorkbook.Sheets(1).Range("B" & LastRowMaster + 1 & ":B" & LastRowMaster + DataRowsSource).Value = FileNameSource
            ThisWorkbook.Sheets(1).Range("C1:E1").Copy
            ThisWorkbook.Sheets(1).Range("C" & LastRowMaster + 1 & ":E" & LastRowMaster + DataRowsSource).PasteSpecial xlPasteFormulas
Skip:
    wbk.Close True
    Filename = Dir
Loop
End Sub

VBA Loop through files in folder and copy/paste variable range to master file

2 Answers2