Copying data from multiple workbooks to another

Question

I have a workbook which has two sheets:

'Data Processing' contains a list of cell references as follows:

Input Column    Input Row Start Input Row End       Output Column
C               88              105                 A
H               198             215                 B
G               253             270                 C

'Results' contains an empty table with headers in row 1.

I want a VBA macro which opens every .xls file in the current folder, and copies data from the first sheet of each one into the 'Results' sheet according to the table of data.

For example, the first workbook should be opened, and the data held in C88:C105 should be copied into column A of 'Results', followed by H198:H215 into row B, followed by G253:G270 into column C.

This should be repeated for each workbook in the folder, the data being inserted into the first blank row (which can be taken as the first blank cell in column A) in the 'Results' sheet.

This is what I have:

Sub Consolidate()

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


Set destsheet = Workbooks("Consolidate_data.xlsm").Worksheets("Results")

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

'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.Range("A1").End(xlDown).Offset(1, 0).Row 

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

    Do While IsEmpty(ActiveCell) = False
        originsheet.Range(ActiveCell.Value & ActiveCell.Offset(0, 1).Value & ":" & ActiveCell.Value & ActiveCell.Offset(0, 2).Value).Copy
        destsheet.Range(ActiveCell.Offset(0, 4).Value & ResultRow & ":" & ActiveCell.Offset(0, 4).Value & (ResultRow + (ActiveCell.Offset(0, 2).Value - ActiveCell.Offset(0, 1).Value))).PasteSpecial
        ActiveCell.Offset(1, 0).Select
    Loop
    Workbooks(Fname).Close SaveChanges:=False   'close current file
    Fname = Dir     'get next file
Loop
End Sub

Currently the macro stops at ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0) '.End(xlDown).Offset(1, 0).Row with 'Run time error 1004: Application error or object-defined error'.

Any ideas?

Answer 1

Use Option Explicit

You should declare all your variables. Excel can help you with that if you use the Option Explicit .

Error origin

In your case :

destsheet.Range("A1").End(xlDown).Offset(1, 0) returns a Range

but you may want ResultRow to be a Long

You should either use :

for a Range:

Set ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0)

or for a Long:

ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0).Row

Answer 2

I think your real problem is that you are trying to do too much in one statement. This means that neither you nor anyone else can look at your code and see what it is trying to do. The more complex your code, the longer it takes you to get it right and the longer it will take you to understand it when you have to update it in six months time. The code below might take marginally longer to run but it is easy to understand and easy to update.

This code is not quite how I would have done but I have tried to follow your style.

Replace:

ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0).Row

by:

ResultRow = destsheet.Cells(Rows.Count, "A").End(xlUp).Row + 1

Add the following variables

Dim ColDest As String
Dim ColSrc As String
Dim RngDest As String
Dim RngSrc As String
Dim RowInstructCrnt As Long
Dim RowSrcEnd As Long
Dim RowSrcStart As Long

Replace your Do loop with:

RowInstructCrnt = 2
With ThisWorkbook.Worksheets("Data Processing")
  Do While Not IsEmpty(.Cells(RowInstructCrnt, "A"))
    ColSrc = .Cells(RowInstructCrnt, "A")
    RowSrcStart = .Cells(RowInstructCrnt, "B")
    RowSrcEnd = .Cells(RowInstructCrnt, "C")
    ColDest = .Cells(RowInstructCrnt, "D")
    RngSrc = ColSrc & RowSrcStart & ":" & ColSrc & RowSrcEnd
    RngDest = ColDest & ResultRow
    originsheet.Range(RngSrc).Copy
    destsheet.Range(RngDest).PasteSpecial
    RowInstructCrnt = RowInstructCrnt + 1
 Loop
End With

Note: not only is each statement of the above code a single step, it does not move the cursor around the worksheet "Data Processing".

Answer 3

解决方案如下（如上面的评论）：

ResultRow = destsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row