Macro To Copy Specific cells From Multiple Workbooks to New Summary Workbook

Hello mooseman60,

Are these workbooks the only files in the folder? If not, is there some pattern to the workbook names to distinguish them from any other workbooks?

NOTE: Your workbook did not attach to your post.

Hello Mooseman60,

Okay, that's not a problem since the macro will be run from the Summary workbook.

Hello Mooseman60,

Is column "D" used for anything?

Hello Mooseman60,

That will make this much easier. Thanks.

Make sure you specify the path to the folder you want to get the files from. Also , I am not sure what the name of the sheet you want to copy the data from, so I just called it sheet1, if it is a different name, change that too. The code is in Module one, make necessary changes there.

Edit: Sorry Leith , I did not see you had posted while I was writing the code.

Sub dave()

    Dim cel As Range, wb, iRow
    Dim fl, sh As Worksheet
    Dim rng As Range
      Application.ScreenUpdating = 0
        iRow = 3
        Set wb = Workbooks.Add(1)
        With CreateObject("scripting.filesystemobject")
                 For Each fl In .getfolder("C:\YourFilePath").Files ' you have to enter your path the the folder
                  If Left(.getextensionname(fl), 2) = "xl" Then
                    With Workbooks.Open(fl)
                      With Sheets("Sheet1")  'change the sheet name if needed.
                        wb.Cells(iRow, 1).Value = .Cells(19, 5).Value
                        wb.Cells(iRow, 2).Value = .Cells(10, 12).Value
                        wb.Cells(iRow, 3).Value = .Cells(9, 12).Value
                        wb.Cells(iRow, 5).Value = .Cells(17, 12).Value
                        wb.Cells(iRow, 6).Value = .Cells(15, 12).Value + .Cells(16, 12).Value
                        iRow = iRow + 1
                      End With
                      .Close True
                    End With
                  End If
                Next
       End With
     Application.ScreenUpdating = 1
End Sub

Hello Mooseman,

The attached workbook has the macro below added to it. All the workbooks in the folder will have their data from the cells you mentioned added to "Sheet1" starting on row 3. Each workbook's data is added directly below the previous the data with no blank rows. There is a butoon on "Sheet1" to run the macro.

' Thread:  http://www.excelforum.com/excel-programming/838877-macro-to-copy-specific-cells-from-multiple-workbooks-to-new-summary-workbook.html
' Poster:  Mooseman60

Sub CreateSummary()

    Dim Cell As Range
    Dim DstRng As Range
    Dim DstWks As Worksheet
    Dim Filename As String
    Dim Filepath As String
    Dim R As Long
    Dim RngEnd As Range
    Dim SrcWkb As Workbook
    Dim SrcWks As Worksheet
    
        Filepath = ThisWorkbook.Path & "\"
        Filename = ThisWorkbook.Name
        
        Set DstWks = Worksheets("Sheet1")
        Set DstRng = DstWks.Range("A3:F3")
        
            Set RngEnd = DstWks.Cells(Rows.Count, "A").End(xlUp)
            Set DstRng = IIf(RngEnd.Row < DstRng.Row, DstRng, RngEnd.Offset(1, 0))
            
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            
            Do While Filename <> ""
                If Filename <> ThisWorkbook.Name Then
                    Set SrcWkb = Workbooks.Open(Filename)
                        Set SrcWks = SrcWkb.Worksheets(1)
                        With DstRng.Offset(R, 0)
                            .Cells(1, 1) = SrcWks.Range("E19")
                            .Cells(1, 2) = SrcWks.Range("L10")
                            .Cells(1, 3) = SrcWks.Range("L9")
                            .Cells(1, 5) = SrcWks.Range("L17")
                            .Cells(1, 6) = SrcWks.Range("L15") + SrcWks.Range("L16")
                        End With
                    R = R + 1
                    SrcWkb.Close SaveChanges:=False
                End If
                Filename = Dir()
            Loop
    
            Application.Calculation = xlCalculationManual
            Application.ScreenUpdating = False
   
End Sub

What is the sheet name in your 27 workbooks? Is it Sheet1?

Whoops, my mistake, I left out the sheet name in my code.

try this.

Sub dave()

    Dim cel As Range, wb, iRow
    Dim fl, sh As Worksheet
    Dim rng As Range
      Application.ScreenUpdating = 0
        iRow = 3
        Set wb = Workbooks.Add(1)
        With CreateObject("scripting.filesystemobject")
                 For Each fl In .getfolder("YourFilePath").Files ' you have to enter your path the the folder
                  If Left(.getextensionname(fl), 2) = "xl" Then
                    With Workbooks.Open(fl)
                      With Sheets("Quote Template")  'change the sheet name if needed.
                             wb.Sheets(1).Cells(iRow, 1).Value = .Cells(19, 5).Value
                             wb.Sheets(1).Cells(iRow, 2).Value = .Cells(10, 12).Value
                             wb.Sheets(1).Cells(iRow, 3).Value = .Cells(9, 12).Value
                             wb.Sheets(1).Cells(iRow, 5).Value = .Cells(17, 12).Value
                             wb.Sheets(1).Cells(iRow, 6).Value = .Cells(15, 12).Value + .Cells(16, 12).Value
                        iRow = iRow + 1
                      End With
                      .Close True
                    End With
                  End If
                Next
       End With
     Application.ScreenUpdating = 1
End Sub

Can you post one of the workbooks you are trying to get data from?

I can't open your zip file, can you post another way?

No This won't open either. Try uploading it via the forums tools. Use manage attachments, when you use "Go Advanced" when posting.
If the file is too big, just delete some data, I just want to see what the file looks like.

When zipped it is an unrecognizable file. Delete most of the data and post normally.

In the sample workbook there is no sheet with the name "Quote Template" is this correct?

In that case , where does the macro show an error?

I just tested the below code and it works fine. Either your path is incorrect or the sheet name you are trying to get data from is incorrect. One last possibility is that you have saved the file which you run the macro from in the same folder as the 27 workbooks.

Is "RW645" the folder name or the workbook name?

For Each fl In .getfolder("C:\Users\Craig\Documents\RW645").Files

If it is the workbook name you need to change it to this.

For Each fl In .getfolder("C:\Users\Craig\Documents").Files

Sub dave()

    Dim cel As Range, wb, iRow
    Dim fl, sh As Worksheet
    Dim rng As Range
      Application.ScreenUpdating = 0
        iRow = 3
        Set wb = Workbooks.Add(1)
        With CreateObject("scripting.filesystemobject")
                 For Each fl In .getfolder("C:\Users\Craig\Documents").Files ' you have to enter your path the the folder
                  If Left(.getextensionname(fl), 2) = "xl" Then
                    With Workbooks.Open(fl)
                      With Sheets("Quote Template")  'change the sheet name if needed.
                             wb.Sheets(1).Cells(iRow, 1).Value = .Cells(19, 5).Value
                             wb.Sheets(1).Cells(iRow, 2).Value = .Cells(10, 12).Value
                             wb.Sheets(1).Cells(iRow, 3).Value = .Cells(9, 12).Value
                             wb.Sheets(1).Cells(iRow, 5).Value = .Cells(17, 12).Value
                             wb.Sheets(1).Cells(iRow, 6).Value = .Cells(15, 12).Value + .Cells(16, 12).Value
                        iRow = iRow + 1
                      End With
                      .Close True
                    End With
                  End If
                Next
       End With
     Application.ScreenUpdating = 1
End Sub

Ok, lets try something else.

Save the following zip file to your desktop, create a new folder (Not zipped) and name it what you like, drag and drop the files in the zip folder to your new folder(The names of the workbooks must stay the same). Save the Consolidate file to your desktop as well.

Now open the consolidate_Ver2 file and and run the macro, you will be asked to select a file. Navigate to the folder you just created and pick any of the three files(it does not matter which one).
The macro should run and have created a new workbook with 3 workbooks data in it. Lets see if this works first.

That code was only a test to see if you had the path correctly entered into the file, unless you will be changing folders all the time you don't want to always have to navigate through the folder picker.


The below code will enable you to pick and file in your folder that you want to get data from and not worry about how long its name is.

Sub dave()

    Dim cel As Range, wb, iRow
    Dim fl, sh As Worksheet
    Dim rng As Range, filePath, FolderPath
      Application.EnableEvents = 0
      Application.ScreenUpdating = 0
      Application.DisplayAlerts = 0
       filePath = Application.GetOpenFilename("Excel & CSV Files, *.xls*; *.csv")
        FolderPath = Left(filePath, (InStrRev(filePath, "\") - 1))
       iRow = 3
        Set wb = Workbooks.Add(1)
        With CreateObject("scripting.filesystemobject")
                 For Each fl In .getfolder(FolderPath).Files ' you have to enter your path the the folder
                  If Left(.getextensionname(fl), 2) = "xl" Then
                    With Workbooks.Open(fl)
                      With Sheets("Quote Template")  'change the sheet name if needed.
                             wb.Sheets(1).Cells(iRow, 1).Value = .Cells(19, 5).Value
                             wb.Sheets(1).Cells(iRow, 2).Value = .Cells(10, 12).Value
                             wb.Sheets(1).Cells(iRow, 3).Value = .Cells(9, 12).Value
                             wb.Sheets(1).Cells(iRow, 5).Value = .Cells(17, 12).Value
                             wb.Sheets(1).Cells(iRow, 6).Value = .Cells(15, 12).Value + .Cells(16, 12).Value
                        iRow = iRow + 1
                      End With
                      .Close True
                    End With
                  End If
                Next
       End With
     Application.DisplayAlerts = 1
     Application.ScreenUpdating = 1
     Application.EnableEvents = 1
End Sub

However if you don't want to navigate through the file picker, let me know and I will amend the code and show you how to get the correct file path of your folder.

Do you have any passwords in the workbooks? try moving the folder to desktop and see what happens?

Ok, I was able to open your actual file and it takes a stack of time to open. I timed the procedure on my machine which has 16 gig of memory and it still took over 3 mins to run. Can you run the macro for about 30 sec and then press Ctrl + Pause Break key at the same time. This will forcibly stop the code. Then can you tell if any data has been transferred to the report workbook?

To give you an idea, I can run this code through about 70 workbooks in under 30sec.

Good to know. I think your workbooks are pretty heavily loaded with formulas , so it is a necessary evil. Cheers