CODEWITHSUNDEEP
vbaexcel
slandau
slandau

Reputation: 24052

Excel Macros - Copy and paste filtered rows

So based off of a dropdown selection in sheet "B", we want to scroll through a bunch of rows in sheet "A", delete all of them that don't have a Cell(4) = dropDownValue, and then copy that range and paste it into sheet "B". The code below runs but doesn't do anything.

I can debug and see that the dropDownValue is stored correctly, and also that the Cell(4) seems to get pulled correctly for every row it loops through. Brand new to VBA here, coming from a C# background, so this seems very confusing to me.

Any ideas on how to fix this or what I'm doing wrong?

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

Upvotes: 1

Views: 5992

Answers (2)

Reafidy
Reafidy

Reputation: 8431

When deleting rows like that you need to work backwards. Try:

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

NOTE A: In VBA all dimensioning should be at the top of the module.

NOTE B: Looping is okay but if you want to improve efficiency or you have many rows to search then instead of looping use autofilter with a formula and then delete visible rows.

NOTE C: When working with rows use long instead of integer to prevent overflow so in your case: 

Dim i As Long

NOTE D: As Tim mentioned above.

Here is some changes which might 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

Example of the autofilter method:

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

Upvotes: 2

Siddharth Rout
Siddharth Rout

Reputation: 149287

My reply is based on what I understood from this line which you mentioned in your post

delete all of them that don't have a Cell(4) = dropDownValue

My First question would be.

What kind of data do you have in Col E? Numbers or Text?

If it is text then you can use this code which is very fast. It uses "Autofilter" rather than looping the cells.

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

And if it is numbers then use this

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

Upvotes: 0

Related Questions