Копирование на основе критериев и вставка на другой лист

Question

Я пытаюсь получить свой код для копирования на основе критериев (есть несколько ячеек, соответствующих критериям), а затем вставьте его на другой лист под уже существующими ячейками.Я использовал .AutoFilter для этого.

Я написал приведенный ниже код, но он содержит ошибки в .AutoFilter и в ws1.copyFrom.Copy.

Справочная информация: Критерий "Активен""найдено в ведомостях (" Бункер будущего проекта "), которое находится в столбце D15 и ниже.Скопируйте данные из столбцов D: J, которые соответствуют вышеуказанным критериям.Вставьте его в Sheets («CPD-Carryover, Complete & Active») в диапазоне C25: J25 под данными, которые уже есть.

Есть ли способ сделать это?

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

Answer 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

Answer 2

Попробуйте этот код;я заменил .autofilter на .showalldata для очистки фильтров на листе.Обработка ошибок, охватывающая .showalldata, заключается в том, что на листе нет фильтров для начала.Я также добавил «.SpecialCells (xlCellTypeVisible)» к диапазону, который вы пытаетесь скопировать, чтобы он пытался скопировать только видимые ячейки, полученные в результате фильтрации.Dim wb1 As Workbook Dim ws1 As Worksheet, ws2 As Worksheet Dim copyFrom As Range Dim lRow As Long Dim Отвечать как 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