CODEWITHSUNDEEP
excelvba
Pawel
Pawel

Reputation: 49

Set range for filter

I have macro which copy filtered rows (filter in column E, >0) from one sheet (ws1) to another (ws2).

I cannot find why I have error when trying to set up filter in source (ws1) in line 2. I assume this might be a reason of my problem, because macro copy all lines including title of each column (line with filter). Maybe issue is with copy function? Now I'm not sure. Because of that I have always delete one row after copy.

Set rngToCopy = .SpecialCells(xlCellTypeVisible)

Source file: DropBox

Full code:

Sub COPY_SA()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
Set ws1 = ThisWorkbook.Worksheets("SA")
Set ws2 = ThisWorkbook.Worksheets("JC_input")

With ws1

    'assumung that data stored in column C:E, Sheet1
    lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
    'can not make range from row 3 ???
    Set rng = .Range("C1:F" & lastrow)

    .AutoFilterMode = False
    With rng
        'apply filter with criteria in column 3 of range C:E
        .AutoFilter Field:=3, Criteria1:=">0"
        On Error Resume Next
        'get only visible rows
        Set rngToCopy = .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    End With

    'copy range
    If Not rngToCopy Is Nothing Then rngToCopy.Range("A:D").Copy
    'paste from row 3
    ws2.Range("A3").PasteSpecial Paste:=xlValues
    'delete no needed row, because of filter from row 2 in ws1
    ws2.Rows(3).Delete

    End With

Application.CutCopyMode = False
  If Not ActiveSheet.AutoFilterMode Then
    ws1.Range("2:2").AutoFilter
    End If

End Sub

Upvotes: 0

Views: 2177

Answers (1)

Damian
Damian

Reputation: 5174

This is how I would do it:

Option Explicit
Sub COPY_SA()

    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("SA")
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("JC_input")

    Dim lastrow As Long

    With ws2

        'assumung that data stored in column C:E, Sheet1
        lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row

        If .AutoFilterMode Then .AutoFilterMode = False

        .Range("C2:F" & lastrow).AutoFilter 3, ">0" 'change the 5 if you don't want to filter by column E

        'Calculate again the last row to check if there is something to copy
        lastrow = .Cells(2, "C").End(xlDown).Row

        Dim rngToCopy  As Range

        If lastrow > 2 Then 'assuming your headers are on row 2, change this if not
            Set rngToCopy = .Range("C3:F" & lastrow).SpecialCells(xlCellTypeVisible) 'copy visible data
            With ws1
                lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
                .Range("A3:D" & lastrow).ClearContents
                rngToCopy.Copy
                .Range("A3").PasteSpecial xlPasteValues
                .Rows(lastrow + 1 & ":" & ws1.Rows.Count).ClearContents 'this will clear your previous data on all columns
            End With
            .Range("E2").AutoFilter
            Application.CutCopyMode = False
        End If

    End With

End Sub

Upvotes: 1

Related Questions