Macro code to open files and copy data into active workbook

[Lizard07]

Hello - I would like to create a macro code that opens up multiple workbooks and copy/pastes three cells of data into the active workbook.

The three cells of data are located in the same three cells and the location that they will be copied to is also the same. In total, I will need it to open up 15 workbooks, copy and paste 15 sets of data, and paste into the active workbook or the "master" workbook

I'd like to avoid doing an import, and I'd also like it to close each workbook after copying the data from it.

Suggestions? Thanks

 

[John_w]

Write a Dir function loop with Workbooks.Open for each file. Example of code - http://www.mrexcel.com/forum/showpost.php?p=2855997&postcount=10

 

[Lizard07]

This code works well for what I'm looking for, I just have one question. How do I get it to copy/paste the data of the next workbook into the next available cells. Right now it is copy/pasting over the previous workbook's data

 

[John_w]

Which 3 cells should be copied and where should they be copied to in the master workbook? Define exactly 'next available cells', i.e. which row and/or column.

 

[Lizard07]

In each workbook I am copying cells B1, B2, and B3 and they are copied into the active workbook starting in cell C9 and then going down from there. So for for the first workbook, B1:B3 would be copied into C9:11. Then the next workbook's B1:B3 would be copied into C12:14 and so on

 

[John_w]

Use a row index variable starting at 9 and increment it by 3 each time. Post your code if you need help with this.

 

[Lizard07]

Yah sorry gonna need some help with the increment piece

Sub Create_Month_Summary()
Dim folderPath As String
Dim fileName As String
Dim thisWorkbook As Workbook
Dim dayNumber As Integer
Dim workbookDate As Date

'Folder containing daily dated workbooks for a month - CHANGE AS REQUIRED

folderPath = "P:\PROJECT\XATA Data Tracking\Activity Reports"

Set thisWorkbook = ActiveWorkbook

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

fileName = Dir(folderPath & "*.xlsm")
Do While fileName <> ""

'Copy data from dated workbook to associated row in summary sheet

Workbooks.Open folderPath & fileName
With thisWorkbook.Sheets("Sheet2").Range("C9")
.Offset(0, 0).Value = Sheets("Trailer Summary").Range("B1").Value
.Offset(1, 0).Value = Sheets("Trailer Summary").Range("B2").Value
.Offset(2, 0).Value = Sheets("Trailer Summary").Range("B3").Value
End With
ActiveWorkbook.Close savechanges:=False

'Get next file name

fileName = Dir
Loop

MsgBox "Finished"

End Sub

Thanks

 

[John_w]

Ah ok, you're using a row offset from C9. Same idea, just maintain a rowOffset variable starting at 0 and incrementing by 3 for each opened workbook:

Sub Create_Month_Summary()
    Dim folderPath As String
    Dim fileName As String
    Dim thisWorkbook As Workbook
    Dim dayNumber As Integer
    Dim workbookDate As Date
    Dim rowOffset As Long
    
    'Folder containing daily dated workbooks for a month - CHANGE AS REQUIRED
    
    folderPath = "P:\PROJECT\XATA Data Tracking\Activity Reports"
    
    Set thisWorkbook = ActiveWorkbook
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    rowOffset = 0
    fileName = Dir(folderPath & "*.xlsm")
    Do While fileName <> ""
    
        'Copy data from dated workbook to associated row in summary sheet
        
        Workbooks.Open folderPath & fileName
        
        With thisWorkbook.Sheets("Sheet2").Range("C9")
            .Offset(rowOffset, 0).Value = Sheets("Trailer Summary").Range("B1").Value
            .Offset(rowOffset + 1, 0).Value = Sheets("Trailer Summary").Range("B2").Value
            .Offset(rowOffset + 2, 0).Value = Sheets("Trailer Summary").Range("B3").Value
        End With
        rowOffset = rowOffset + 3
        ActiveWorkbook.Close savechanges:=False
        
        'Get next file name
        
        fileName = Dir
    Loop
    
    MsgBox "Finished"

End Sub

The whole With...End With can be replaced with one line to copy the cells:

        Sheets("Trailer Summary").Range("B1:B3").Copy thisWorkbook.Sheets("Sheet2").Range("C9").Offset(rowOffset, 0)

 

[Lizard07]

That worked great, thank-you so much