fix copy cells macro

I've come across a problem with this macro.

As I requested the macro will add 5 lines to the next free row available in the worksheet. The trouble is that 90% of the time this work sheet will be filtered so that column A on the result_example sheet excludes the blank cells leaving only the names in column A. When I run the macro and there is a filter on column A it is causing less info to be copied over to the destination workhseet.

When there is no filter applied it works fine and all 5 rows and the correct values are copied over as links.

Perhaps a way of getting round this would be for the macro to unfilter column A>>>then run the current code>>> then reapply the filter*

*filter = select all values in column A excluding (blanks)

Perhaps you may know of a more efficient way of doing this.

I've tweaked the current code (see below) so if you could apply the changes to this and re-paste a a snippet of the new code it would be much appreciated.

Option Explicit

Sub NewCode()
''/// the sheet name will need to be changed to actual name used in the final workbook

    If ActiveSheet.Name = "Stakeholder_Actionpoints" Then
        MsgBox "You have the rsults sheet active.", vbCritical, "Error"
        Exit Sub
    End If
    Dim ws As Worksheet
    Dim rToCopy As Range
    Dim lRw As Long
    Dim iX As Integer
    '1. Copy all values (including blank cell values) from the range A14:E18 and paste under the relevant column headings found in sheet Stakeholder_Actionpoints
    Set ws = ActiveSheet
    Set rToCopy = ws.Range(Cells(14, 1), Cells(18, 5))


    With Sheet55
        lRw = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        rToCopy.Columns(1).Copy
        Application.Goto .Cells(lRw, 2)
        ActiveSheet.Paste Link:=True
        rToCopy.Columns(2).Copy
        Application.Goto .Cells(lRw, 1)
        ActiveSheet.Paste Link:=True
        rToCopy.Columns(3).Copy
        Application.Goto .Cells(lRw, 5)
        ActiveSheet.Paste Link:=True
        rToCopy.Columns(5).Copy
        Application.Goto .Cells(lRw, 3)
        ActiveSheet.Paste Link:=True
        rToCopy.Columns(6).Copy
        Application.Goto .Cells(lRw, 4)
        ActiveSheet.Paste Link:=True

        For iX = 1 To rToCopy.Rows.Count

            .Hyperlinks.Add Anchor:=.Cells(lRw, 6), Address:="", SubAddress:= _
                            "'" & ws.Name & "'!A" & iX + 13, TextToDisplay:=ws.Name

            lRw = lRw + 1

        Next iX
    End With
End Sub

Select allOpen in new window

Thanks Mike
EmailIt-macro--1---1---1-.xlsm