无法将数据从一张纸填充到另一张纸

Question

我是宏的新手，请在下面的代码帮助我，不要将所有记录从一张纸粘贴复制到另一张纸。 它仅复制一行，其余部分不复制，请纠正我的代码出错的地方。

Private Sub CopyData()
Dim LastRow As Integer, i As Integer, erow As Integer

LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

'If Cells(i, 1) = Date And Cells(i, 2) = “Sales” Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy

Worksheets("Sheet3").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
'ActiveWorkbook.Close
Application.CutCopyMode = False
'End If

Next i
End Sub

Answer 1

上面的评论正确无误，表示在复制/粘贴数据时最好避免使用SELECT，他为您提供了一个很好的链接。

无论如何，您已经使用SELECT编写了代码，因此我将仅添加到您的代码中使其生效。

您面临的问题是，您将复制第二行（对于i = 2 <-这是第二行），选择Sheet3作为“活动表”，然后粘贴它，但是您永远都不会指定我们需要Sheet1是“活动工作表”以复制下一行。

此处更新了代码，可将所有行从Sheet1复制到Sheet3

Private Sub CopyData()
Dim LastRow As Integer, i As Integer, erow As Integer
Worksheets("Sheet1").Select 'Set Active sheet to "Sheet1" 
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'Get last row

For i = 1 To LastRow 'start loop, with row 1 as first row to copy. Adjust as needed
    Range(Cells(i, 1), Cells(i, 4)).Select 'select that row
    Selection.Copy 'copy the row

    Worksheets("Sheet3").Select 'now select the sheet where you want to paste it
    ActiveSheet.Cells(i, 1).Select 'we can use i variable, this will paste it in the same row number as it were in Sheet1
    ActiveSheet.Paste 
    Application.CutCopyMode = False
    Worksheets("Sheet1").Select 'now Select Sheet1 again so you can copy the next row

Next i
End Sub

Answer 2

使用自动筛选器可以轻松地完成基于两个列条件的单元格列的复制。

Option Explicit

Private Sub CopyData()

    With ActiveSheet
        If .AutoFilterMode Then .AutoFilterMode = False

        With .Cells(1, 1).CurrentRegion

            .AutoFilter field:=1, Criteria1:=Date
            .AutoFilter field:=2, Criteria1:="sales"

            With .Resize(.Rows.Count - 1, 4).Offset(1, 0)
                If CBool(Application.Subtotal(103, .Cells)) Then
                    .SpecialCells(xlCellTypeVisible).Copy _
                      Destination:=Worksheets("sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                End If
            End With

        End With

        .AutoFilterMode = False
    End With

End Sub

Answer 3

有条件复制到其他工作表

• 每个 .Range 和 .Cells 均引用 With 中的工作表 声明，在这种情况下为“ Sheet1 ”。
• 在循环完成后保存工作表。
• 尽量不要使用Select和Activate，因为它们会减慢速度 下来。
• 您无需在计算erow时使用Offset，只需加1 到该行。
• 父项属性用于解决对象的“父项” 在with语句中，即“ Sheet1 ”。你可以那样说 父母是指高于该水平的一个工作簿。所以在这种情况下，这意味着ThisWorkbook或通常意味着 工作簿（“ asdfasdfasdfsafds.xls”）。不使用时使用 对工作簿感兴趣，或者您不知道名字等。

代码

Sub CopyData()

  Const cVntSource As Variant = "Sheet1"  ' SourceWorksheet Name/Index
  Const cVntTarget As Variant = "Sheet3"  ' Target Worksheet Name/Index

  Dim wsSource As Worksheet               ' Source Worksheet
  Dim wsTarget As Worksheet               ' Target Worksheet
  Dim LastRow As Long                     ' Source Last Row
  Dim i As Integer                        ' Source Row Counter
  Dim erow As Integer                     ' Target Row Counter

  Set wsSource = Worksheets(cVntSource)
  Set wsTarget = Worksheets(cVntTarget)

  With wsSource

    LastRow = .Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To LastRow

      If .Cells(i, 1) = Date And .Cells(i, 2) = "Sales" Then
        erow = wsTarget.Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Range(.Cells(i, 1), .Cells(i, 4)).Copy wsTarget.Cells(erow, 1)
      End If

    Next

    .Parent.Save
'    .Parent.Close

  End With

End Sub