VBA Pull data from closed multiple workbooks into Master workbook/sheet

[breg523]

Hi everyone,

Not to savvy with VBA data gymnastics however I am more familiar with excel formulation. I have a bunch of workbooks in folder 'C:\Users\BCR\Desktop\TSA' i am only interested in one sheet 'Custom Award File' and only interested in columns A-I. The first row is row title and i want to append the data into a master sheet. the title of the workbook files are dynamic, based on the date and other random naming convention. My question is, is there a macro/vba that can copy data from all the closed workbooks in sheet 'Custom Award File' into a master workbook. the sheet name does not change in any of the files. Please let me know if you have any questions. There are about 10-30 files in the folder that get updated progressively throughout the month.

 

[mumps]

This macro assumes that the source workbooks are the only files in your folder and that they have an "xlsx" externsion. Make sure that a sheet named "Master" exists in your destination workbook and that the first row in that sheet contains your headers from A:I.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook
    Set desWS = ThisWorkbook.Sheets("Master")
    Dim LastRow As Long
    Const strPath As String = "C:\Users\BCR\Desktop\TSA\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB.Sheets("Custom Award File")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A2:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End With
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[breg523]

This macro assumes that the source workbooks are the only files in your folder and that they have an "xlsx" externsion. Make sure that a sheet named "Master" exists in your destination workbook and that the first row in that sheet contains your headers from A:I.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook
    Set desWS = ThisWorkbook.Sheets("Master")
    Dim LastRow As Long
    Const strPath As String = "C:\Users\BCR\Desktop\TSA\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB.Sheets("Custom Award File")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A2:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End With
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Wow! thank you so much for this!! It seems to be working. honestly cant thank you enough ...quick question: is there a recommended number of files that can be in the folder? basically since its daily data I am thinking i can aggregate the data from other months for example have 2019 ytd data which would be like 120+ files.

 

[mumps]

You are very welcome. There is no set number of files that can be imported. The more files you have, the longer it will take the macro to do its job.

 

[scwoo]

This macro assumes that the source workbooks are the only files in your folder and that they have an "xlsx" externsion. Make sure that a sheet named "Master" exists in your destination workbook and that the first row in that sheet contains your headers from A:I.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook
    Set desWS = ThisWorkbook.Sheets("Master")
    Dim LastRow As Long
    Const strPath As String = "C:\Users\BCR\Desktop\TSA\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB.Sheets("Custom Award File")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A2:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End With
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Hi,
Thanks mumps. This code works for me too! Just one problem, the data in my source worksheets are derived from formulas. When I run the VBA, it copies the formulas over to the destination worksheet, instead of data.

For examples: First column of my report is "File Name", which I got it using =(MID(CELL("filename",A1),FIND("[",CELL("filename",A1))+1,FIND("]", CELL("filename",A1))-FIND("[",CELL("filename",A1))-1) . When run VBA, the records in "File Name" column in Master worksheet all reflected the destination file name, not data as per my source worksheet.

Can you help to modify the code so that it just copy & paste value the data, not formula? Thank you.

 

[mumps]

Replace this line of code:

.Range("A2:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)

with these two lines:

.Range("A2:I" & LastRow).Copy
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

 

[scwoo]

Replace this line of code:

.Range("A2:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)

with these two lines:

.Range("A2:I" & LastRow).Copy
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

It works perfectly, exactly what I have been looking for! Thank you so much & stay safe.

 

[mumps]

You are very welcome. Thank you and you as well.

 

[scwoo]

Replace this line of code:

.Range("A2:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)

with these two lines:

.Range("A2:I" & LastRow).Copy
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Hi mumps,

Would like to seek your help again. After pulling data from multiple workbooks in a folder, I realize I need the last modified date for each workbook to be added in last column of the destination worksheet, for tracking of daily productivity. Possible you can help by modifying the existing vba code (below) for this additional requirement? Thanks.

Sub CopyRange()
Application.ScreenUpdating = False
Dim desWS As Worksheet, srcWB As Workbook
Set desWS = ThisWorkbook.Sheets("Master")
Dim LastRow As Long
Const strPath As String = "C:\Users\BCR\Desktop\TSA\"
ChDir strPath
strExtension = Dir(strPath & "*.xlsx")
Do While strExtension <> ""
Set srcWB = Workbooks.Open(strPath & strExtension)
With srcWB.Sheets("Custom Award File")
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("A2:I" & LastRow).Copy
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End With
srcWB.Close False
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[mumps]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, s As String
    Set desWS = ThisWorkbook.Sheets("Master")
    Dim LastRow As Long
    Const strPath As String = "C:\Users\BCR\Desktop\TSA\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xls*")
    Do While strExtension <> ""
        s = FileLastModified(strPath & strExtension)
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB.Sheets("Custom Award File")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A2:I" & LastRow).Copy
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Cells(.Rows.Count, "J").End(xlUp).Offset(1, 0).Resize(LastRow - 1) = s
            End With
        End With
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Function FileLastModified(strFullFileName As String)
    Dim fs As Object, f As Object, s As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(strFullFileName)
    s = UCase(strFullFileName) & vbCrLf
    s = f.DateLastModified
    FileLastModified = s
    Set fs = Nothing: Set f = Nothing
End Function