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

オブジェクトが必要です

.Offset(k - 1, j - 1).Value = "='" & Target1.Parent.Name & "'!" & myArray(i)

Option Explicit

Dim FilePath As String
Dim FileName As String
Dim Pos As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim Target1 As Range, Target2 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_paste()

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 Target1 = Application.InputBox("参照範囲を選択してください", Type:=8)
    On Error GoTo 0
    
    If Target1 Is Nothing Then Exit Sub
    
    '参照範囲の行列数の取得
    Target1.Select
    Set cTarget = Selection.SpecialCells(xlCellTypeVisible)
    
    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
            
    '配列にセルアドレスを格納
    i = 1
    For Each trg In Target1
        ReDim Preserve myArray(i)
        
        If trg.EntireRow.Hidden = False And trg.EntireColumn.Hidden = False Then
            myArray(i) = trg.Address
            i = i + 1
        End If
    Next trg
    
    With ThisWorkbook.Sheets(1)
        .Cells(2, 3) = Target1.Parent.Name
        .Cells(2, 4) = Target1.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 Target2 = Application.InputBox("貼付け範囲を選択してください", Type:=8)
    On Error GoTo 0
    If Target2 Is Nothing Then Exit Sub
    
    '貼付け範囲の行列数の取得
    Target2.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
    
    '表示セルにセルアドレスを引用してセル参照
    i = 1
    With ActiveCell
        j = 1
        For k = 1 To cntRow
            If .Offset(k - 1, j - 1).EntireRow.Hidden = False Then
                For j = 1 To cntCol
                    If .Offset(k - 1, j - 1).EntireColumn.Hidden = False Then
                        .Offset(k - 1, j - 1).Value = "='" & Target1.Parent.Name & "'!" & myArray(i)
                        i = i + 1
                    End If
                Next j
            End If
        Next k
    End With
    
    Sheets(Target2.Parent.Name).Select
    
    With ThisWorkbook.Sheets(1)
        .Cells(3, 3) = Target2.Parent.Name
        .Cells(3, 4) = Target2.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

            If wb.FullName = FilePath Then
                Workbooks(FileName).Close
            End If