VBAで可視セルのみをリンク貼付けする処理を行うマクロ

WorksheetクラスのPasteメソッドが失敗しました。

ActiveSheet.Paste Link:=True

Option Explicit

Dim FilePath As String
Dim FileName As String
Dim Pos As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim Target As Range, cTarget As Range, vTarget As Range
Dim i As Integer, j As Integer, k As Integer
Dim cpcnt As Integer
Dim trg As Range
Dim myArray() As Variant
Dim cpcntRow As Long, cpcntCol As Long
Dim vcntRow As Long, vcntCol As Long
Dim cntRow As Long, cntCol As Long
Dim rc As Integer


Sub visible_copy_pastelink()

Range(Cells(2, 3), Cells(3, 5)).ClearContents '入力フォームの記入を削除

'ダイアログからコピーファイルを開く
FilePath = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") 'FilePath変数に対象ブックのパスを格納する（Excel ブックだけを候補に表示）
Pos = InStrRev(FilePath, "\") 'ファイル名の文字位置を検索
FileName = Mid(FilePath, Pos + 1) 'ファイル名の取得

    If FilePath <> "False" Then
        For Each wb In Workbooks
            If wb.FullName = FilePath Then
                Workbooks(FileName).Close
            End If
        Next wb
        Workbooks.Open FilePath, ReadOnly:=True '読み取り専用で開く
    Else
        Exit Sub
    End If
    
    'ダイアログからシートを選択
    Set ws = ShowSelectSheetDialog()
    ws.Activate
    
    On Error Resume Next
    Set Target = Application.InputBox("参照範囲を選択してください", Type:=8)
    On Error GoTo 0
    
    If Target Is Nothing Then Exit Sub
    
    'コピー範囲の行列数の取得
    Target.Select
    Set cTarget = Selection.SpecialCells(xlCellTypeVisible)
    
    cTarget.Select
    Selection.Copy
    
    cpcnt = cTarget.Count

    cntRow = 0
    cntCol = 0
    With Selection
        For i = 1 To .Areas.Count
            cntRow = cntRow + .Areas(i).Rows.Count
            cntCol = cntCol + .Areas(i).Columns.Count
        Next i
    End With

    cpcntRow = 0
    cpcntCol = 0
    
    With ActiveCell
        j = 1
        For k = 1 To cntRow
            If .Offset(k - 1, j - 1).EntireRow.Hidden = False Then
                    cpcntRow = cpcntRow + 1
                For j = 1 To cntCol
                    If .Offset(k - 1, j - 1).EntireColumn.Hidden = False Then
                        cpcntCol = cpcntCol + 1
                    End If
                Next j
            End If
        Next k
    End With
    
    With ThisWorkbook.Sheets(1)
        .Cells(2, 3) = Target.Parent.Name
        .Cells(2, 4) = Target.Address
        .Cells(2, 5) = FilePath
    End With

'ダイアログからコピーファイルを開く
FilePath = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") 'FilePath変数に対象ブックのパスを格納する（Excel ブックだけを候補に表示）
Pos = InStrRev(FilePath, "\") 'ファイル名の文字位置を検索
FileName = Mid(FilePath, Pos + 1) 'ファイル名の取得

    If FilePath <> "False" Then
        For Each wb In Workbooks
            If wb.FullName = FilePath Then
                Workbooks(FileName).Close
            End If
        Next wb
        Workbooks.Open FilePath, ReadOnly:=True '読み取り専用で開く
    Else
        Exit Sub
    End If
    
    'ダイアログからシートを選択
    Set ws = ShowSelectSheetDialog()
    ws.Activate
    
    On Error Resume Next
        Set Target = Application.InputBox("貼付け範囲を選択してください", Type:=8)
    On Error GoTo 0
    If Target Is Nothing Then Exit Sub
    
    '貼付け範囲の行列数の取得
    Target.Select
    Set vTarget = Selection.SpecialCells(xlCellTypeVisible)
    
    cpcnt = vTarget.Count

    cntRow = 0
    cntCol = 0
    With Selection
        For i = 1 To .Areas.Count
            cntRow = cntRow + .Areas(i).Rows.Count
            cntCol = cntCol + .Areas(i).Columns.Count
        Next i
    End With

    vcntRow = 0
    vcntCol = 0
    
    With ActiveCell
        j = 1
        For k = 1 To cntRow
            If .Offset(k - 1, j - 1).EntireRow.Hidden = False Then
                    vcntRow = vcntRow + 1
                For j = 1 To cntCol
                    If .Offset(k - 1, j - 1).EntireColumn.Hidden = False Then
                        vcntCol = vcntCol + 1
                    End If
                Next j
            End If
        Next k
    End With
    
    '可視セルのコピーセルと貼付けセルの数の確認
    
    If cpcnt <> vTarget.Count Then
        MsgBox "参照セルと貼付けセルの数が一致しません。確認して下さい。"
        Exit Sub
    End If

    If cpcntRow <> vcntRow Or cpcntCol <> vcntCol Then
        MsgBox "参照セルと貼付けセルの行列の数が一致しません。確認して下さい。"
        Exit Sub
    End If
    
    vTarget.Select
    Application.EnableEvents = False
    ActiveSheet.Paste Link:=True

    Sheets(Target.Parent.Name).Select
    
    With ThisWorkbook.Sheets(1)
        .Cells(3, 3) = Target.Parent.Name
        .Cells(3, 4) = Target.Address
        .Cells(3, 5) = FilePath
    End With
    
    MsgBox "完了しました"
    
End Sub

' シート選択ダイアログを表示
' 戻り値：選択されたシートオブジェクト
Public Function ShowSelectSheetDialog() As Worksheet

    Dim ShBackup As Worksheet
    Application.ScreenUpdating = False
    Set ShBackup = ActiveSheet
    With CommandBars.Add(Temporary:=True)
        .Controls.Add(ID:=957).Execute
        .Delete
    End With
    
    Set ShowSelectSheetDialog = ActiveSheet
    
    ShBackup.Select
    Application.ScreenUpdating = True

End Function

    On Error Resume Next
        Set Target = Application.InputBox("貼付け範囲を選択してください", Type:=8)
    On Error GoTo 0