Copy Resized Range of Filtered Data in VBA

[DenialDan]

Hello,

As the title suggests I'm trying to copy a range of filtered cells. The source has a lot more than 5 rows but of these filtered cells I'm only trying to copy the first 5. This is the code I've been using so far:

Sub Top5()


Dim CopyRange As Range


Sheets(5).Range("B3").AutoFilter Field:=1, Criteria1:="2017-Q3"
Sheets(7).Range("B3").AutoFilter Field:=1, Criteria1:="2017-Q3"


On Error Resume Next
With Sheets(5).AutoFilter.Range


    Set CopyRange = .Offset(1, 0).Resize(5).SpecialCells(xlCellTypeVisible)


End With


CopyRange.Copy Sheets("FC").Range("C30:C34") 


End Sub

I've added the resize property for ensuring it's not longer than 5 rows and the offset property so the header is excluded.
My problem is that this code copies the whole table but I only want to copy the first five in column "B" and only 3 rows are copied.

Best Regards,
DenialDan.

 

[Domenic]

Try...

[FONT=Arial][COLOR=darkblue]Sub[/COLOR] Top5()

    [COLOR=darkblue]Dim[/COLOR] FiltRange [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] CopyRange [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] Rw [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] RwCnt [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    
    Sheets("FC").Range("C30").CurrentRegion.ClearContents [COLOR=green]'optional[/COLOR]
    
    [COLOR=darkblue]With[/COLOR] Sheets(5)
        [COLOR=darkblue]If[/COLOR] .FilterMode [COLOR=darkblue]Then[/COLOR] .ShowAllData
        .Range("B3").AutoFilter Field:=1, Criteria1:="2017-Q3"
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
    [COLOR=darkblue]With[/COLOR] Sheets(5).AutoFilter.Range
        [COLOR=darkblue]Set[/COLOR] FiltRange = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
    
    [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] FiltRange [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
        RwCnt = 0
        [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] Rw [COLOR=darkblue]In[/COLOR] FiltRange.Rows
            RwCnt = RwCnt + 1
            [COLOR=darkblue]If[/COLOR] CopyRange [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
                [COLOR=darkblue]Set[/COLOR] CopyRange = Rw
            [COLOR=darkblue]Else[/COLOR]
                [COLOR=darkblue]Set[/COLOR] CopyRange = Union(CopyRange, Rw)
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
            [COLOR=darkblue]If[/COLOR] RwCnt = 5 [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]For[/COLOR]
        [COLOR=darkblue]Next[/COLOR]
        CopyRange.Copy Sheets("FC").Range("C30")
        Sheets("FC").Activate [COLOR=green]'optional[/COLOR]
     [COLOR=darkblue]Else[/COLOR]
        Sheets("FC").Activate [COLOR=green]'optional[/COLOR]
        MsgBox "No records found.", vbInformation
     [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
     
     Sheets(5).AutoFilter.ShowAllData [COLOR=green]'optional[/COLOR]

[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR][/FONT]

Hope this helps!

 

[DenialDan]

Thanks for the reply Domenic. Sadly when I implemented the code im getting a run-time error '1004': This action won't work on multiple selections. The debugger point to the line:

CopyRange.Copy Sheets("FC").Range("C30")[/FONT][/COLOR][COLOR=#333333][FONT=Arial]

 

[Domenic]

Did you make any changes to the code? If so, can you post the exact code that you're using?