宏复制范围和粘贴基于单元格值 [英] Macro to Copy Range and Paste Based on Cell Value

问题描述

我创建了一个宏来复制数据并将其粘贴到另一张纸上。

I had created a macro to copy the data and paste into another sheet.

需要粘贴数据的单元格引用位于表的最后一列。

The cell reference where the data needs to be pasted is in the last column of table.

需要复制范围A2：E2并粘贴到 A2（在 H2中提到）

Range A2:E2 needs to be copied and paste at "A2" (mentioned in "H2")

以下代码不断给出错误消息必需对象

The below code constantly gives and error "Object Required"

工作表的Google文档版本

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

推荐答案

尝试以下代码（在示例表和目标的说明位于 H 列中，而不是示例VBA中的 I ）

Try the following code (in the sample sheet and in the description the target is in H column, not I as in sample 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

编辑：

我认为没有循环就无法实现，但是我将代码编辑为：

I don't think you can achieve that without a loop, but I have edited the code to:

• 禁用屏幕更新


• 禁用事件


• 禁用公式计算


• 分配范围值，而不是复制/粘贴

• disable screen updates
• disable events
• disable formula calculation
• assign range values instead of copy/paste

在我的计算机上，在不到3秒的时间内完成了18000行的测试。

On my computer test with 18000 rows finished in less than 3 seconds.

这篇关于宏复制范围和粘贴基于单元格值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！