SpecialCells(xlCellTypeVisible)

Question

I have 15 columns of data, with rows ranging from 400 - 1000, and I have applied filters, I am keen to only copy visible cells, for column D and J, onto a different sheet, but paste special values through transpose into range D6.

I have used this below method, but it is only copying two visible rows, and not every single row according to the code, like it has done for me in the past for other sheets I have run after amending it. The problem could be I am running three or four process in one macro.

I would be keen to know how I can amend this code so it copies column d and column j visible cells, excluding headers into a different sheet

So where do I stand with the code, it runs and applies the filters, but fails to copy all the rows for this particular part of the macro and secondly, I would be keen to know how to amend it so it only copies the Column D and J as the above excluding headers and only copies visible cells for to paste special values through transpose.

Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
Report.Range("D6").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True


Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long
    Dim rngToCopy As Range, rRange As Range

    Set ws = Sheets("Sheet1")

    With ws
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        Set rRange = .Range("A1:A" & lRow)

        '~~> Remove any filters
        .AutoFilterMode = False

        With rRange 'Filter, offset(to exclude headers) and copy visible rows
            .AutoFilter Field:=1, Criteria1:="<>"
            Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        '~~> Remove any filters
        .AutoFilterMode = False

        rngToCopy.Copy

        '
        '~~> Rest of the Code
        '
    End With
End Sub

I added thomas code to sub piece to see if the autofilter works and getting error 91

Sub Filter()
Dim Sheetx As Worksheet
Dim rngToCopy As Range, rRange As Range

With Sheetx

Set rRange = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))

With rRange

.AutoFilter Field:=11, Criteria1:="30"
.AutoFilter Field:=4, Criteria1:="1"
.AutoFilter Field:=2, Criteria1:="=*1", _
Operator:=xlAnd


With .SpecialCells(xlCellTypeVisible)

Set rngToCopy = Union(.Offset(0, 3), .Offset(0, 9))

End With

rngToCopy.Copy

End With
End With

End Sub

Unknown Unknown · Accepted Answer · 2016-11-18T00:46:39

We can use Union and Range.Offset to join the cells together define the range.

MSDN: Application.Union Method (Excel)

Returns the union of two or more ranges.

Sub Sample()

    Dim lRow As Long
    Dim rngToCopy As Range, rRange As Range


    With Sheets("Sheet1")

            With .Range("A1").CurrentRegion
                .AutoFilter Field:=11, Criteria1:="=30"
                .AutoFilter Field:=4, Criteria1:="=1"
                .AutoFilter Field:=2, Criteria1:="=1", _
                Operator:=xlAnd

                On Error Resume Next
                Set rngToCopy = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0

                If rngToCopy Is Nothing Then
                    MsgBox "SpecialCells: No Data", vbInformation, "Action Cancelled"
                    Exit Sub
                End If


                Set rngToCopy = Intersect(rngToCopy, .Range("B:B,H:H"))

                 If rngToCopy Is Nothing Then
                    MsgBox "Intersect: No Data", vbInformation, "Action Cancelled"
                    Exit Sub
                End If
        End With
    End With

    rngToCopy.Copy


    Sheets("Sheet2").Range("C6").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=True

End Sub

SpecialCells(xlCellTypeVisible)

1 Answers