Excel 宏：根据条件将行值从一个工作表复制到另一个工作表中的特定位置

Question

我现在只在 Excel 中使用宏大约 4 个月，基本上是通过查找现有代码并弄清楚它是如何工作的来自学的。我现在有点卡住了。

我在 Excel 工作簿中有一份报告。我需要根据 D 列中出现的数据跨多个工作表（在同一个工作簿中）复制数据。也就是说，我需要复制 D 列与某些条件匹配的整行。原始工作表包含公式，但我只希望在复制数据时出现这些值。

我已经能够复制数据，但我有两个问题： 1）公式正在复制，而不仅仅是值 2) 数据出现在单元格 A2 的新工作表中，但我需要它从单元格 A5 开始

我将其设置为模板，因为主要报告需要每月运行和拆分，因此我复制的范围不会是恒定的。这是我当前使用的代码示例：

    Sub RefreshSheets()

    Sheets("ORIGIN").Select
    Dim lr As Long, lr2 As Long, r As Long
    lr = Sheets("ORIGIN").Cells(Rows.Count, "A").End(xlUp).Row
    lr2 = Sheets("DESTINATION").Cells(Rows.Count, "A").End(xlUp).Row

    For r = lr To 2 Step -1
        If Range("D" & r).Value = "movedata" Then
            Rows(r).Copy Destination:=Sheets("DESTINATION").Range("A" & lr2 + 1)
            lr2 = Sheets("DESTINATION").Cells(Rows.Count, "A").End(xlUp).Row
        End If


    Next r

    End Sub

我尝试在“.Range("A" & lr2 + 1)”之后添加“.PasteSpecial Paste:=xlPasteValues”，但出现编译错误（预期：语句结束）。我确信我错过了一些明显的东西（这是我使用我还不完全理解的代码所得到的），但到目前为止我所尝试的都没有奏效。

任何建议将不胜感激。

Answer 1

第一个版本使用 For 循环（行数很多时速度会很慢）

Option Explicit

Public Sub RefreshSheets()
    Dim wsO As Worksheet, wsD As Worksheet, lrO As Long, lrD As Long, r As Long

    Set wsO = ThisWorkbook.Sheets("ORIGIN")
    Set wsD = ThisWorkbook.Sheets("DESTINATION")
    lrO = wsO.Cells(Rows.Count, "A").End(xlUp).Row
    lrD = wsD.Cells(Rows.Count, "A").End(xlUp).Row

    If lrD < 5 Then lrD = 5

    For r = lrO To 2 Step -1
        If wsO.Range("D" & r).Value2 = "movedata" Then
            wsO.Rows(r).Copy
            wsD.Range("A" & lrD + 1).PasteSpecial xlPasteValues
            lrD = lrD + 1
        End If
    Next
End Sub

---

此版本使用自动过滤器一次复制所有带有“movedata”的行：

Public Sub RefreshSheetsFast()
    Dim wsO As Worksheet, wsD As Worksheet, lrD As Long

    Set wsO = ThisWorkbook.Sheets("ORIGIN")
    Set wsD = ThisWorkbook.Sheets("DESTINATION")
    lrD = wsD.Cells(Rows.Count, "A").End(xlUp).Row

    If lrD < 5 Then lrD = 5    'Makes sure the first row on DESTINATION sheet is >=5

    If Not wsO.AutoFilter Is Nothing Then wsO.UsedRange.AutoFilter
    With wsO.UsedRange
        .Columns(4).AutoFilter Field:=1, Criteria1:="movedata"
        .Offset(1).Resize(.Rows.Count - 1).Copy        'Excludes the header (row 1)
    End With
    wsD.Range("A" & lrD + 1).PasteSpecial xlPasteValues

    Application.CutCopyMode = False
    wsO.UsedRange.AutoFilter    'Removes the "movedata" filter
End Sub

Answer 2

将复制和粘贴作为两个单独的请求执行：

Sub RefreshSheets()
  Sheets("ORIGIN").Select
  Dim lr As Long, lr2 As Long, r As Long
  lr = Sheets("ORIGIN").Cells(Rows.Count, "A").End(xlUp).Row
  lr2 = Sheets("DESTINATION").Cells(Rows.Count, "A").End(xlUp).Row

  For r = lr To 2 Step -1
      If Range("D" & r).Value = "movedata" Then
          Rows(r).Copy
          Sheets("DESTINATION").Range("A" & lr2 + 1).PasteSpecial xlPasteValues
          lr2 = Sheets("DESTINATION").Cells(Rows.Count, "A").End(xlUp).Row
      End If
  Next r
End Sub