环路值传送至的范围底部被错误地重写值

Question

我有个范围，作为从另一个宏原始数据转储。在此范围内，我希望VBA要经过一定的柱（柱Q），当标准是1，复制目标范围，并移动到一个表的底部。我不知道该表的VBA，所以才确定了最后一排，加入1桌子的底部粘贴，因为该表将自动调整。

我的代码做的一切，我需要以下情况除外：它找到的每个实例，它是在底部粘贴......但因为它循环，它将覆盖在表的底部形成，而不是寻找新行最后一项下面粘贴。我尝试添加一个睡眠计时器，这是我能看到它覆盖，但它并没有解决问题。

数据转储范围：列W至AC值在第4行到任何最后一行是从数据转储开始。列X - 标准柱，0或1。如果为1则数据需要被移动。列X通过AA，的标准= 1被从该区域移动，以表中。

表头开始A3和向下行309如果我有数据转储5项，那么我期待这些值粘贴下面的表格，开始在列C.因此该行扩大从309到313。

Public Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)

Sub test1()
    Dim Cell As Range
    Dim lastrow As Long
    Dim TargtRng As Range

    With Sheets("Data_Rates")
        lastrow = Worksheets("Data_Rates").Cells(Rows.Count, "C").End(xlUp).Row + 1

        For Each Cell In .Range("X4:X" & .Cells(.Rows.Count, "X").End(xlUp).Row)
            If Cell.Value = "1" Then
                '.Range(Cell, Cell.Offset(, 3)).Copy Destination:=.Cells(lastrow, "C")
                Set TargtRng = .Range(Cell, Cell.Offset(, 3))
                .Range(Cells(lastrow, "C"), Cells(lastrow, "E")).Resize(TargtRng.Rows.Count, TargtRng.Columns.Count).Value = TargtRng.Cells.Value
                Sleep (500)
            End If
        Next Cell
    End With
End Sub

Answer 1

试试这个，稍作简化，但与循环内的最后一排可变最重要的，以便为您在复制的数据越多更新。

Sub test1()

Dim Cell As Range
Dim lastrow As Long
Dim TargtRng As Range

With Sheets("Data_Rates")
    For Each Cell In .Range("X4:X" & .Cells(.Rows.Count, "X").End(xlUp).Row)
        If Cell.Value = 1 Then
            lastrow = .Cells(Rows.Count, "C").End(xlUp).Row + 1
            .Cells(lastrow, "C").Resize(, 4).Value = Cell.Resize(, 4).Value
        End If
    Next Cell
End With

End Sub