Copying data from specific cells across multiple workbooks to 'master workbook' programmatically

Question

I have two questions but first a bit of background...

I have a number of workbooks each containing a different number of worksheets all saved in the same folder. Each worksheet except the first has an invoice from which I need data from specific cells copied on to the master sheet.

The Master sheet has 5 columns which will be populated with the information from the same 5 cells on each sheet on the following row.

Invoice Sheets Cell  Master Sheet Row
     E9                   A
     D18                  B
     D22                  C
     E11                  D
     F27                  E

.

Sub Consolidate()

Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim ColDest As String
Dim ColSrc As String
Dim RngDest As String
Dim RngSrc As String
Dim InvTotal As String
Dim RowInstructCrnt As Long
Dim RowSrcEnd As Long
Dim RowSrcStart As Long



Set destsheet = Workbooks("Test Master.xlsm").Worksheets("Sheet1")


'get list of all files in folder
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")

'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
    Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
    Set originsheet = wkbkorigin.Worksheets("Sheet1")

    'find first empty row in destination table
    ResultRow = destsheet.Cells(Rows.Count, "A").End(xlUp).Row + 1

    'start at top of list of cell references and work down until empty cell reached
    Application.Goto ThisWorkbook.Worksheets("Sheet1").Range("D16")


   With ThisWorkbook.Worksheets("Sheet1")
  Do While Not IsEmpty(.Cells(16, 4))
    ColSrc = .Cells(9, 5)
    RowSrcStart = .Cells(18, 4)
    RowSrcEnd = .Cells(22, 4)
    ColDest = .Cells(11, 5)
    InvTotal = .Cells(27, 6)
    RngSrc = ColSrc & RowSrcStart & ColSrc & RowSrcEnd & InvTotal
    RngDest = ColDest & ResultRow
    originsheet.Range(RngSrc).Copy
    destsheet.Range(RngDest).PasteSpecial

 Loop
 End With
Workbooks(Fname).Close SaveChanges:=False   'close current file
    Fname = Dir     'get next file
Loop
End Sub

So my first question is - how can I modify this code to make it paste the correct information in the correct cells...

Secondly - I've not yet attempted looping through each sheet in the workbooks as I'm not sure where to begin...

Any advice would be greatly appreciated

So you want to copy the information to the first sheet in each workbook, or to a sheet in the workbook which contains the macro? It's a little difficult to follow from your code. — Tim Williams
Hi Tim, the information will be copied into the next empty row of Sheet1 in a workbook called master which contains the macro. Thank you for responding. — dhk83

Tim Williams Tim Williams · Accepted Answer · 2014-11-25T20:11:25

Untested:

Sub Consolidate()

Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range


    Set destsheet = ThisWorkbook.Worksheets("Sheet1")
    Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp) _
                       .Offset(1, 0).EntireRow
    Fname = Dir(ThisWorkbook.Path & "/*.xlsx")

    'loop through each file in folder (excluding this one)
    Do While Fname <> "" And Fname <> ThisWorkbook.Name

        If Fname <> ThisWorkbook.Name Then

            Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
            Set originsheet = wkbkorigin.Worksheets("Sheet1")

            With RngDest
                .Cells(1).Value = originsheet.Range("E9").Value
                .Cells(2).Value = originsheet.Range("D18").Value
                .Cells(3).Value = originsheet.Range("D22").Value
                .Cells(4).Value = originsheet.Range("E11").Value
                .Cells(5).Value = originsheet.Range("F27").Value
            End With

            wkbkorigin.Close SaveChanges:=False   'close current file
            Set RngDest = RngDest.Offset(1, 0)

        End If

        Fname = Dir()     'get next file
    Loop
End Sub

Copying data from specific cells across multiple workbooks to 'master workbook' programmatically

1 Answers