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.

 

[scwoo]

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

You are genius!! I just made a few minor tweaks on the name of the worksheet, path, range and cell and the code works nicely as it expected. Cannot thank you enough for your help. ??

 

[mumps]

You are most welcome.

 

[Yoanna]

Hello,
I am trying to utilize the vba macro in my daily work but I am experiencing the following problem. I would like to extract values from the first column, let's say, from multiple excel files in a specified directory and then transpose those values in rows in the master file with the vba code. I've tried a couple of changes of the code but none of them worked out the way I wanted. Could you, please, help me modify the code so I can transpose the extracted values in specified rows in my file.

Thank you very much.

Regards,
Yoanna

 

[mumps]

What is the full path to the folder containing the files? Are these files the only files in that folder? What is the extension of the files (xlsx, xlsm)? Do you want to extract column A from one sheet in each file or from all sheets? If one sheet, what is the name of that sheet? What is the name of the destination sheet in the master file?

 

[Yoanna]

The idea is that this specific folder should contain only files with xlsm extension at the end. I want to extract data from cells with a range A2:A6, from multiple xlsm files. After that all of the data should be transposed into rows with a range from A to E within the master excel file in which the macro is stored. Your vba code works perfectly for me when I trigger it for this purpose but the data which i am trying to pull is located in a column, not in a row. I have successfully replaced the folder path, the name of the sheet and everything else. This is the only issue left for me to solve. The xlsm files are identical in their structure, the names of the sheets are identical as well. I want to extract the data only from 1 sheet in each file ( 5 cells).

 

[mumps]

Please post the version of the macro you are currently using.

 

[Yoanna]

This is the macro that I am currently using.
Sub PullData()

Application.ScreenUpdating = False
Dim desWS As Worksheet, srcWB As Workbook, strFileName As String
Dim objMyFile As Object

Set desWS = ThisWorkbook.Sheets("Sheet1")
Dim LastRow As Long
Const strPath As String = "C:\Users\usr\Desktop\New folder\"
ChDir strPath
strextension = Dir(strPath & "*.xlsm")

Do While strextension <> ""


Set srcWB = Workbooks.Open(strPath & strextension)
With srcWB.Sheets("Sheet1")
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

I really appreciate your help!

 

[mumps]

Try:

Sub PullData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, strFileName As String
    Dim objMyFile As Object
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Const strPath As String = "C:\Users\usr\Desktop\New folder\"
    ChDir strPath
    strextension = Dir(strPath & "*.xlsm")
    Do While strextension <> ""
        Set srcWB = Workbooks.Open(strPath & strextension)
        With srcWB.Sheets("Sheet1")
            desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(, 5).Value = Application.WorksheetFunction.Transpose(.Range("A2:A6").Value)
        End With
        srcWB.Close False
        strextension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Also, when posting code, please use code tags. Copy the code, click the "<vba/>" button in the menu and then paste the code. Please edit Post #17 to add the code tags.

 

[Yoanna]

This is the macro that I am currently using.
Sub PullData()

Application.ScreenUpdating = False
Dim desWS As Worksheet, srcWB As Workbook, strFileName As String
Dim objMyFile As Object

Set desWS = ThisWorkbook.Sheets("Sheet1")
Dim LastRow As Long
Const strPath As String = "C:\Users\usr\Desktop\New folder\"
ChDir strPath
strextension = Dir(strPath & "*.xlsm")

Do While strextension <> ""


Set srcWB = Workbooks.Open(strPath & strextension)
With srcWB.Sheets("Sheet1")
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

Hello, again! I couldn't edit Post #17 , so I am posting the old version of the code again. I am sorry for the inconvenience but I am new to this forum and I was not familiar with the rules.
Your solution works perfectly for me. I couldn't thank you enough!

 

[mumps]

You are very welcome. Forum rules can be found here: Message Board Rules