基于单元格值多次复制粘贴数据

Question

我有两张：DataEntry和Datasheet。 DataEntry上的C4和Number (Quantity of Data)上的E4上写有数据。我希望根据Datasheet上提到的次数在DataEntry E4上粘贴数据。

对于Eg。 DataEntry上提到的数据是

C4 = Markers
E4 = 5

所以我希望在Datasheet中将此标记的5次粘贴在相应的行中，并在下一列中添加日期，以及在最后数据下添加的其他项目：

DataSheet中的情况如何：

  A2       B2
Markers 01-Jan-14
Markers 01-Jan-14
Markers 01-Jan-14
Markers 01-Jan-14
Markers 01-Jan-14

有人可以帮助我使用上面的VBA代码

Answer 1

这是我使用Worksheet Event的版本。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim entry As Range, count As Range, dest As Range
Dim i As Integer, j As Integer
Dim query As Integer

On Error Goto errhandler
Application.EnableEvents = False

Set entry = ThisWorkbook.Sheets("DataEntry").Range("C4")
Set count = ThisWorkbook.Sheets("DataEntry").Range("E4")

Set dest = ThisWorkbook.Sheets("DataSheet").Range("A" & _
    Rows.count).End(xlUp).Offset(1, 0)

If Not Intersect(Target, count) Is Nothing Then
    query = MsgBox("Copy Data?", vbYesNo)
    If query = 7 Then Exit Sub
    i = Target.Value
    For j = 1 To i
        Target.Offset(0, -2).Copy dest
        With dest.Offset(0, 1)
            .Value = Date
            .NumberFormat = "dd-mmm-yy"
        End With
        Set dest = ThisWorkbook.Sheets(2).Range("A" & _
            Rows.count).End(xlUp).Offset(1, 0)
    Next
End If

continue:
Application.EnableEvents = True

Exit Sub
errhandler:
MsgBox Err.Description
Resume continue

End Sub

希望这有帮助。
每当您更改E4数据中的值时，获胜C4将复制到您的DataSheet。
代码位于Sheet，而不是Module。

Answer 2

试试这个：

Sub CopyBasedOnQuantity()

    Dim DataEntry As Worksheet, DataSht As Worksheet
    Dim ItemName As Range, ItemCount As Range
    Dim NRow As Long, TargetCell As Range

    With ThisWorkbook
        Set DataEntry = .Sheets("DataEntry")
        Set DataSht = .Sheets("Datasheet")
    End With

    With DataEntry
        Set ItemName = .Range("C4")
        Set ItemCount = .Range("E4")
    End With

    With DataSht
        NRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
        Set TargetCell = .Range("A" & NRow)
        TargetCell.Resize(ItemCount.Value, 1).Value = ItemName.Value
        TargetCell.Offset(0, 1).Resize(ItemCount.Value, 1).Value = Date
    End With

End Sub

<强>截图：

<强> 设置：

<强> 结果：

如果有帮助，请告诉我们。