Макрос для копирования диапазона и вставки на основе значения ячейки

Question

Я создал макрос для копирования данных и вставки в другой лист.

Ссылка на ячейку, где данные должны быть вставлены, находится в последнем столбце таблицы.

Диапазон A2: E2 необходимо скопировать и вставить в "А2" (упоминается в "H2")

Код ниже постоянно дает и ошибка "Требуется объект"

Google Doc Version of the Worksheet

---

Sub Reconcile() 

Set i = Sheets("Data") 
Set e = Sheets("Final") 

Dim r1 As Range 
Dim r2 As Variant 
Dim j 
j = 2 
Set r1 = i.Range(Cells(j, 1), Cells(j, 5)) 
Set r2 = i.Cells("I" & j).Value 

Do Until IsEmpty(i.Range("A" & j)) 
    r1.Select 
    Selection.Copy 
    e.Range(r2).Select 
    Selection.Paste 
    j = j + 1 
Loop 

End Sub 

Answer 1

Попробуйте следующий код (в образце листа и в описании цель находится в H колонке, не I как в образце VBA)

Sub Reconcile() 

Set i = Sheets("Data") 
Set e = Sheets("Final") 

Dim r1 As Range 
Dim r2 As Range 
Dim j As Integer 
j = 2 

Application.ScreenUpdating = False 
Application.EnableEvents = False 
Application.Calculation = xlCalculationManual 

Do Until IsEmpty(i.Range("A" & j)) 
    Set r1 = i.Range(Cells(j, 1), Cells(j, 5)) 
    Set r2 = e.Range(i.Range("H" & j).Value) 
    r2.Resize(1, 5).Value = r1.Value 
    j = j + 1 
Loop 

Application.ScreenUpdating = True 
Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 

End Sub 

EDIT:

Я не думаю, что вы можете добиться того, что без петли, но я редактировал код:

• отключить обновления экрана
• отключить события
• отключить формулу расчета
• значений диапазона правопреемником вместо копирования/вставки

На моем компьютере тест с 18000 строк готовой менее чем за 3 секунды.

Answer 2

Вы не измеряли все свои переменные. Дайте мне знать, если это не исправить вашу ошибку:

Sub Reconcile() 

Dim i as Worksheet 
Dim e As Worksheet 
Dim r1 As Range 
Dim r2 As Variant 
Dim j As Integer 

Set i = Sheets("Data") 
Set e = Sheets("Final") 

j = 2 
Set r1 = i.Range(Cells(j, 1), Cells(j, 5)) 
Set r2 = i.Cells("I" & j).Value 

Do Until IsEmpty(i.Range("A" & j)) 
    r1.Select 
    Selection.Copy 
    e.Range(r2).Select 
    Selection.Paste 
    j = j + 1 
Loop 

End Sub