SpecialCells(xlCellTypeVisible) - vba

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

Answer 1

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