Копирование данных из нескольких рабочих книг в другую

Question

У меня есть рабочая тетрадь с двумя листами:

«Обработка данных» содержит список ссылок на ячейки следующим образом:

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

«Результаты» содержит пустую таблицу с заголовками в строке 1.

Мне нужен макрос VBA, который открывает каждый файл .xls в текущей папке и копирует данные с первого листа каждого в лист «Результаты» в соответствии с таблицей данных.

Например, должна быть открыта первая рабочая книга, и данные, хранящиеся в C88: C105, должны быть скопированы в столбец A «Результаты», затем H198: H215 в строку B, затем G253: G270 в столбец C.

Это должно быть повторено для каждой книги в папке, данные вставляются в первую пустую строку (которая может быть взята в качестве первой пустой ячейки в столбце A) на листе «Результаты».

Вот что у меня есть:

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

В настоящее время макрос останавливается на ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0) '.End(xlDown).Offset(1, 0).Row с «Ошибка времени выполнения 1004: ошибка приложения или ошибка, определенная объектом».

Есть идеи?

Answer 1

Я думаю, что ваша настоящая проблема в том, что вы пытаетесь сделать слишком много в одном утверждении. Это означает, что ни вы, ни кто-либо другой не могут посмотреть на ваш код и увидеть, что он пытается сделать. Чем сложнее ваш код, тем больше времени у вас уходит на то, чтобы понять его правильно, и тем больше времени вам потребуется, чтобы понять его, когда вам потребуется обновить его через шесть месяцев. Выполнение приведенного ниже кода может занять немного больше времени, но его легко понять и легко обновить.

Этот код не совсем так, как я бы сделал, но я пытался следовать вашему стилю.

Заменить:

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

по:

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

Добавьте следующие переменные

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

Замените цикл Do на:

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

Примечание: каждый оператор вышеприведенного кода не только является одним шагом, но и не перемещает курсор вокруг листа «Обработка данных».

Answer 2

Использовать опцию Явный

Вы должны объявить все ваши переменные.Excel может помочь вам в этом, если вы используете Option Explicit.

Источник ошибки

В вашем случае:

destsheet.Range("A1").End(xlDown).Offset(1, 0) возвращает Range

но вы можете захотеть, чтобы ResultRow был Long

. Вы должны использовать:

для диапазона:

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

или для длинных:

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

Answer 3

Решение (как в комментариях выше) было следующее:

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