Макросы Excel - копирование и вставка отфильтрованных строк

Question

Таким образом, основываясь на раскрывающемся списке на листе "B", мы хотим прокрутить несколько строк на листе "A", удалить все из них, у которых нет Cell(4) = dropDownValue, а затем скопировать этот диапазон.и вставьте его в лист "B".Приведенный ниже код работает, но ничего не делает.

Я могу отладить и убедиться, что dropDownValue хранится правильно, а также, что Cell(4), похоже, корректно вытягивается для каждой строки, через которую он проходит.Здесь вы новичок в VBA, пришедший из C #, поэтому мне это очень запутанно.

Есть идеи, как это исправить или что я делаю не так?

Sheets("B").Select
Dim dropDownValue As String
dropDownValue = Left(Range("L1").Value, 3)

Dim wantedRange As Range
Dim newRange As Range
Dim cell As Object
Dim i As Integer
Set wantedRange = Sheets("A").Range("E11:E200")
For i = 1 To wantedRange.Rows.Count Step 1
    Dim target As String
    target = wantedRange.Rows(i).Cells(4)
    If Not (target Like dropDownValue) Then
        wantedRange.Rows(i).Delete
    End If
Next i

Sheets("B").Select
Application.CutCopyMode = False
wantedRange.copy
Selection.wantedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Answer 1

При удалении таких строк вам нужно работать в обратном направлении.Попробуйте:

For i = wantedRange.Rows.Count To 1 Step -1

ПРИМЕЧАНИЕ A : В VBA все размеры должны быть в верхней части модуля.

ПРИМЕЧАНИЕ B : Циклхорошо, но если вы хотите повысить эффективность или у вас есть много строк для поиска, тогда вместо цикла используйте автофильтр с формулой, а затем удалите видимые строки.

ПРИМЕЧАНИЕ C : при работе со строками используйтеlong вместо целого числа, чтобы предотвратить переполнение, поэтому в вашем случае:

Dim i As Long

ПРИМЕЧАНИЕ D : Как упомянул Тим выше.

Вот некоторые изменения, которые могутhelp:

Dim sDropDown As String
Dim lRowCnt As Long

sDropDown = Left(Sheets("B").Range("L1").Value, 3)

With Sheets("A").Range("E11:E200")
    For lRowCnt = .Rows.Count To 1 Step -1
        If Not (.Rows(lRowCnt).Value Like "*" & sDropDown "*") Then
            .Rows(lRowCnt).Delete
        End If
    Next i

    Sheets("B").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With

Пример метода автофильтрации:

Dim sFilter As String

sFilter = "<>*" & Left(Sheets("B").Range("L1").Value, 3) & "*"

Application.ScreenUpdating = False

With Sheets("A").Range("E11:E200")
    .Offset(-1, 0).Resize(.Rows.Count + 1).AutoFilter Field:=1, Criteria1:=sFilter, Operator:=xlAnd
    .EntireRow.Delete
    .Parent.AutoFilterMode = False
    Sheets("B").Cells(1, 1).Resize(.Rows.Count, 1).Value = .Value '// Output
End With

Application.ScreenUpdating = True

Answer 2

Мой ответ основан на том, что я понял из этой строки, которую вы упомянули в своем посте

удалить все из них, которые не имеют ячейку (4) = dropDownValue

Мой первый вопрос будет.

Какие данные у вас есть в полковнике Е? Числа или текст?

Если это текст, вы можете использовать этот код очень быстро. Он использует «Автофильтр», а не зацикливание ячеек.

Option Explicit

Sub Sample()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim LookupVal As String
    Dim ws1rng As Range, toCopyRange As Range

    On Error GoTo Whoa

    Application.ScreenUpdating = False

    Set ws1 = Sheets("A")
    Set ws2 = Sheets("B")

    LookupVal = "<>*" & Left(ws2.Range("L1").Value, 3) & "*"

    Set ws1rng = ws1.Range("E11:E200")

    ws1.AutoFilterMode = False

    With ws1rng
        .AutoFilter Field:=1, Criteria1:=LookupVal, Operator:=xlAnd
        Set toCopyRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
    End With

    ws1.AutoFilterMode = False

    '~~> Will copy the data to Sheet B cell A20
    toCopyRange.Copy ws2.Range("A20")

LetsContinue:
    Application.ScreenUpdating = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

А если это числа, то используйте это

Option Explicit

Sub Sample()
    Dim sDropDown As String
    Dim lRowCnt As Long, i As Long
    Dim delRange As Range

    On Error GoTo Whoa

    Application.ScreenUpdating = False

    sDropDown = Left(Sheets("B").Range("L1").Value, 3)

   With Sheets("A").Range("E11:E200") '<~~ Modified Reafidy's code :)
        For lRowCnt = .Rows.Count To 1 Step -1
            If (.Rows(lRowCnt).Value Like "*" & sDropDown & "*") Then
                If delRange Is Nothing Then
                    Set delRange = .Rows(lRowCnt)
                Else
                    Set delRange = Union(delRange, .Rows(lRowCnt))
                End If
            End If
        Next lRowCnt

        If Not delRange Is Nothing Then
            delRange.Delete
        End If

        lRowCnt = Sheets("A").Range("E" & Rows.Count).End(xlUp).Row

        '~~> Will copy the data to Sheet B cell A20
        Sheets("A").Range("E11:E" & lRowCnt).Copy Sheets("B").Range("A20")
    End With

LetsContinue:
    Application.ScreenUpdating = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub