クリップボードのデータを選択中のセルから可視セルのみに貼り付ける

タイトルのとおりです。でもこれ実はパクリです。

上記のリンク先にある、だるまさんという方の作られた「可視セルへ貼り付け」というマクロに”選択したセル（アクティブセル）から下方向へ貼り付け”という機能を自分なりに追加してみました。青色は私が追加または変更を加えた箇所です。

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

Sub 選択セルから下方向へ可視セルのみに貼り付ける()

    'Microsoft Forms 2.0 Object Library に参照設定要
    '複数セルを選択した状態で実行するとアクティブセル（白抜き）が貼り付け開始位置となる
    '結合セルを選択した状態で実行すると結合セルの左上セルが貼り付け開始位置となる
    '結合セルに貼り付けたい場合は結合セルを選択する。もしくは結合セルの左端と同列のセルを選択する
    'クリップボードの空白行も貼り付ける。Tabは無視される。

    Dim Dobj As DataObject
    Dim V As Variant    'クリップボードのデータ全体
    Dim A As Variant    'その内の一行
    Dim rngDest As Range
    Dim R As Range
    Dim i As Integer
    Dim XS As Integer
    Dim XP As Integer
    Dim YS As Integer
    Dim YP As Integer
    Dim YE As Integer

    If ActiveSheet.AutoFilter Is Nothing Then
        MsgBox "オートフィルターが設定されていません！"
        Exit Sub
    End If

    YP = ActiveCell.Row '現在選択しているセルの行番号を取得
    XP = ActiveCell.Column '現在選択しているセルの列番号を取得
    XP = XP + 1 'AutoFilter.Rangeの左端の列番号が相対的に1となるようにする

YS = ActiveCell.Worksheet.AutoFilter.Range.Row 'オートフィルターが適用される範囲の上端の行番号を取得
XS = ActiveCell.Worksheet.AutoFilter.Range.Column 'オートフィルターが適用される範囲の左端の列番号を取得

YE = ActiveCell.Worksheet.AutoFilter.Range.Rows(ActiveCell.Worksheet.AutoFilter.Range.Rows.Count).Row
'オートフィルターが適用される範囲の下端の行番号を取得

    If YP < YS Or YP > YE Then
        MsgBox ("オートフィルター範囲外（上・下方向）には貼り付けできません！")
        Exit Sub
    End If

    XP = XP - XS
    YP = YP - YS

    With ActiveCell.Worksheet.AutoFilter.Range
        Set rngDest = .Columns(XP)
        Set rngDest = Intersect(rngDest, rngDest.Offset(YP))
        If YP + YS = YE Then    '現在選択しているセルがオートフィルターが適用される範囲の下端の場合は可視セルの取得処理をパスする
        Else
            Set rngDest = rngDest.SpecialCells(xlCellTypeVisible)   '最後に可視セルを取得するのがみそ
        End If
    End With

    Set Dobj = New DataObject
    With Dobj
        .GetFromClipboard
        On Error Resume Next
        V = .GetText
        On Error GoTo 0
    End With

    If Not IsEmpty(V) Then    'クリップボードからテキストが取得できた時のみ実行
        V = Split(CStr(V), vbCrLf)
        i = 0
        For Each R In rngDest.Cells
            A = CStr(V(i))
            R.Value = A
            i = i + 1
            If i > UBound(V) Then Exit For
        Next
    End If

    Set Dobj = Nothing
    Set rngDest = Nothing
    Set R = Nothing
End Sub

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。

上記のコードを実行してコンパイルエラーが発生する場合は？

このコードにはDataObjectという、VBAの標準にはないオブジェクトが使用されているため、実行するにはMicrosoft Forms 2.0 Object Libraryという外部ライブラリーを参照する設定を行う必要があります。つまり具体的に言うとVBEのツール→参照設定→参照からWindows\System32\FM20.DLLを選択する必要があるわけです。（FM20.DLLの保存場所はOSのバージョンによって異なる場合がありますが・・・）

次こそは完全オリジナルのコードを作ります！（作れればいいなぁ）

補足

先にクリップボードにデータがあることが前提になっています。例えば

ABC

DEF

GHI

JKL

MNO

PQR

STU

VWX

のような、改行によって区切られた縦一列の文字列データがクリップボードにあるとします。これをフィルタリングによって抽出された縦一列の可視セルのみに貼り付けることができます。データがたくさんある場合に重宝します。

VBAの勉強を始めてみた

色々試しています。

クリップボードのデータを選択中のセルから可視セルのみに貼り付ける