复制条件范围

Question

我正在尝试根据条件（有多个符合条件的单元格）复制我的代码，然后将其粘贴到已经存在的单元格下面的另一张纸上。我一直在使用.AutoFilter来做到这一点。

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

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

有没有办法做到这一点？

_create_fk_sql

Answer 1

尝试此代码；我用.showalldata替换了.autofilter，以清除工作表上的过滤器。包围.showalldata的错误处理是在工作表上没有过滤器的情况下开始的。我还向要复制的范围添加了“ .SpecialCells（xlCellTypeVisible）”，以便它仅尝试复制过滤产生的可见单元格。昏暗的wb1作为工作簿昏暗的ws1作为工作表，ws2作为工作表 Dim copyFrom作为范围昏暗的行昏暗的回答为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

Answer 2

复制条件范围

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

根据条件进行复制并粘贴到另一张纸上

2 个答案:

复制条件范围