根据标准复制并粘贴到另一个工作表

Posted 2023-03-11

【中文标题】根据标准复制并粘贴到另一个工作表

【英文标题】：Copying Based on a Criteria and Pasting to Another Sheet

【发布时间】：2019-03-07 17:25:46

【问题描述】：

我正试图让我的代码根据一个条件（有多个符合条件的单元格）复制，然后将其粘贴到已经存在的单元格下方的另一个工作表中。我一直在使用 .AutoFilter 来执行此操作。

我编写了以下代码，但在 .AutoFilter 和 ws1.copyFrom.Copy 处出错。

背景： 条件是在位于 D15 列及以下的 Sheets("Future Project Hopper") 中找到的“活动”。 从符合上述条件的 D:J 列中复制数据。 将其粘贴到已存在数据下方 C25:J25 范围内的 Sheets("CPD-Carryover,Complete&Active") 中。

有没有办法做到这一点？

Dim wb1 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim Answer As VbMsgBoxResult

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Future Project Hopper")
Set ws2 = wb1.Worksheets("CPD-Carryover,Complete&Active")

Answer = MsgBox("Do you want to run the Macro?", vbYesNo, "Run Macro")

If Answer = vbYes Then

With ws1

    'clearing any filters
    .AutoFilterMode = False

       lRow = .Range("D" & .Rows.Count).End(xlUp).row

            With .Range("D1:D" & lRow)

                'filtering on column D
                .AutoFilter Field:=4, Criteria1:="Active"
                'Defining range that should be copied - Need C through J and it copies until it's blank cells
                Set copyFrom = .Range("C15:J15" & .Rows.Count).End(xlDown)

            End With

    'clearing any filters
    .AutoFilterMode = False

End With

    'copy range and paste into other worksheet
    ws1.copyFrom.Copy
    ws2.Range("C25:J25").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=False


End If

Application.CutCopyMode = False

【问题讨论】：

不是自动筛选，而是循环遍历列表，如果行符合条件，则移动单元格。此外，电源查询可以轻松完成此操作

你的过滤方法很好——你只需要复制SpecialCells类型的Visible

是的，对于 CPD 表，它将始终从第 25 行开始，对于 Future Project Hopper，它将始终从第 15 行开始。我上面还有其他信息。

【参考方案1】：

复制条件范围

Sub CopyCriteriaRange()

    Const cCrit As Variant = "D"      ' Criteria Column Letter/Number
    Const cCols As String = "C:J"     ' Source/Target Data Columns
    Const cFRsrc As Long = 15         ' Source First Row

    Dim ws1 As Worksheet              ' Source Workbook
    Dim ws2 As Worksheet              ' Target Workbook
    Dim rng As Range                  ' Filter Range, Copy Range
    Dim lRow As Long                  ' Last Row Number
    Dim FRtgt As Long                 ' Target First Row
    Dim Answer As VbMsgBoxResult      ' Message Box

    ' Create references to worksheets.
    With ThisWorkbook
        Set ws1 = .Worksheets("Future Project Hopper")
        Set ws2 = .Worksheets("CPD-Carryover,Complete&Active")
    End With

    Answer = MsgBox("Do you want to run the Macro?", vbYesNo, "Run Macro")

    If Answer <> vbYes Then Exit Sub

    ' In Source Worksheet
    With ws1
        ' Clear any filters.
        .AutoFilterMode = False
        ' Calculate Last Row.
        lRow = .Cells(.Rows.Count, cCrit).End(xlUp).Row
        ' Calculate Filter Column Range.
        Set rng = .Cells(cFRsrc, cCrit).Resize(lRow - cFRsrc + 1)
        ' Make an offset for the filter to start a row before (above) and
        ' end a row after (below).
        With rng.Offset(-1).Resize(lRow - cFRsrc + 3)
            ' Filter data in Criteria Column.
            .AutoFilter Field:=1, Criteria1:="Active"
        End With
        ' Create a reference to the Copy Range.
        Set rng = .Columns(cCols).Resize(rng.Rows.Count).Offset(cFRsrc - 1) _
                .SpecialCells(xlCellTypeVisible)
        ' Clear remaining filters.
        .AutoFilterMode = False
    End With

    ' Calculate Target First Row.
    FRtgt = ws2.Cells(ws2.Rows.Count, cCrit).End(xlUp).Row + 1
    ' Copy Copy Range and paste to Target Worksheet.
    rng.Copy
    ws2.Columns(cCols).Resize(1).Offset(FRtgt - 1).PasteSpecial xlPasteValues

    Application.CutCopyMode = False

End Sub

【讨论】：

感谢@VBasic2008！唯一的问题是它复制活动项目并将值粘贴到 CPD 表中的旧项目上。是否需要将部分代码更改为end.(xlup)？

对不起，我意识到我不是很清楚。项目从第 25 行开始并沿列向下延伸。感谢您的所有帮助！

@ApogWay：修复它。

成功了！如果我想从“Future Project Hopper”中删除“Active”，那只是Sheets("Future Projects Hopper").Activaterng.delete？

@ApogWay：它会删除数据。通常 ClearContents 用于保留格式或清除不。但是您可以随时尝试，而不是保存工作簿并重新打开工作簿。但是如果你想删除行，你可以使用 rng.Rows.Delete: Bye,bye Active。小心，它无法撤消。使用过滤器时要小心。您在 D 列范围中使用了字段 4，它指的是 H 列。它只是 A 列范围内的第 4 个字段。

【参考方案2】：

试试这个代码；我用 .showalldata 替换了 .autofilter 以清除工作表上的过滤器。包含 .showalldata 的错误处理是在工作表上没有过滤器的情况下开始的。我还将“.SpecialCells(xlCellTypeVisible)”添加到您尝试复制的范围中，以便它仅尝试复制过滤产生的可见单元格。 将 wb1 调暗为工作簿 将 ws1 调暗为工作表，ws2 调暗为工作表 暗淡 copyFrom As Range 将 lRow 变暗 模糊答案为 VbMsgBoxResult

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Future Project Hopper")
Set ws2 = wb1.Worksheets("CPD-Carryover,Complete&Active")

Answer = MsgBox("Do you want to run the Macro?", vbYesNo, "Run Macro")

If Answer = vbYes Then

With ws1

'clearing any filters
On Error Resume Next
.ShowAllData
On Error GoTo 0

   lRow = .Range("D" & .Rows.Count).End(xlUp).row

        With .Range("D1:D" & lRow)

            'filtering on column D
            .AutoFilter Field:=4, Criteria1:="Active"
            'Defining range that should be copied - Need C through J and it copies             until it's blank cells
            Set copyFrom = .Range("C15:J15" & .Rows.Count).End(xlDown).SpecialCells(xlCellTypeVisible)

        End With

'clearing any filters
.AutoFilterMode = False

End With

'copy range and paste into other worksheet
ws1.copyFrom.Copy
ws2.Range("C25").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,     Transpose:=False


End If

Application.CutCopyMode = False

【讨论】：

谢谢@MahmoudMostafa！我在本节中遇到了另一个错误：ws1.copyFrom.Copy ws2.Range("C25:J25").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=False 我假设我没有引用正确的目的地，但无法确定哪一部分。

我编辑了代码。您应该粘贴到单个单元格“C25”，数据将从该单元格开始布局。