Question

前段时间我在问题Copy Range and Paste Values in another Sheet's specific Range上收到会员simoco的帮助，复制粘贴脚本效果很好，但现在我需要的东西有点不同。

我需要从一张纸上复制特定的单元格并将其粘贴到另一张纸上的特定范围内，以便构建“数据库”。

这意味着每当我运行脚本时，它都需要将值复制到下一个空行。

我试图通过将数组从Range更改为Cell编号来修改另一个问题中提到的代码，但它不起作用。

我试过了。

Sub Get_Data()
Dim lastrowDB As Long, lastrow As Long
Dim arr1, arr2, i As Integer

With Sheets("DB")
    lastrowDB = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

arr1 = Array("A3", "A4", "A6", "B14")
arr2 = Array("A", "B", "D", "E")

For i = LBound(arr1) To UBound(arr1)
    With Sheets("Sheet1")
         lastrow = Application.Max(3, .Cells(.Rows.Count, arr1(i)).End(xlUp).Row)
         .Range(.Cells(3, arr1(i)), .Cells(lastrow, arr1(i))).Copy
         Sheets("DB").Range(arr2(i) & lastrowDB).PasteSpecial xlPasteValues
    End With
Next
Application.CutCopyMode = False
End Sub

调试指向

lastrow = Application.Max(3, .Cells(.Rows.Count, arr1(i)).End(xlUp).Row)

我不确定如何修改它以使其按预期工作。

提前感谢您的协助。

Answer 1

下面的脚本遍历包含源单元格地址的SourceArr数组，并将值粘贴到DestArr数组中指定的目标列：

Option Explicit
Sub MoveDataToDB()

Dim DB As Worksheet, SH As Worksheet
Dim TargetRow As Long, Index As Long
Dim SourceArr As Variant, DestArr As Variant
Dim Source As Range, Dest As Range

'set references up-front
Set SH = ThisWorkbook.Worksheets("Sheet1")
Set DB = ThisWorkbook.Worksheets("DB")
With DB
    TargetRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With
SourceArr = Array("A3", "A4", "A6", "B14")
DestArr = Array("A", "B", "D", "E")

'loop through the source array, copying cell values to DB sheet
For Index = LBound(SourceArr) To UBound(SourceArr)
    Set Source = SH.Range(SourceArr(Index))
    Set Dest = DB.Range(DestArr(Index) & TargetRow)
    Source.Copy
    Dest.PasteSpecial (xlPasteValues)
Next Index

End Sub

实施下线的一个可能的改进是对IsEmpty范围进行Source检查，以确保已填充正确的单元格。

复制特定单元格并粘贴到另一张纸上

1 个答案: