コピー元の領域を取得する【Excel/VBA】【裏技編】

はじめに

　Excel でコピーや切り取り（カット）をしたときに、そのコピー元になる範囲を VBA で取得したいケースが出ました。

　すでになにかソリューションがないか、ネットで検索してみます。

アニメ「魔道祖師」藍忘機幼少期Ver. 1/8スケールプラスチック製塗装済み完成品フィギュア GAS94522

グッドスマイルアーツ上海(Good Smile Arts Shanghai)

Amazon

VBA コピーされたセル範囲を取得する方法 - Excel | ホームページ制作のサカエン Developer's Blog

　ありました。

Worksheet_SelectionChange イベントと API を利用する必要があります。

　めんどいw

　API 使用すると macOS で使えないんですよ。あとワークシートイベントを使うと、アドイン化するときにまた手間なんですよ。

　それに、自分のプロジェクトに組み込みたいスニペットはもっと短くしてほしいんですよ。できれば 30 行程度の関数やクラス一つで。

　Office クリップボードを VBA で取得する方法はないでしょうか。

Office クリップボードをマクロで操作する(MSAA) | 初心者備忘録

　ありました。

以前書いたコードは、OfficeやOSのバージョンが変わると動作しませんでしたが、今回はバージョンの差異も一応考慮しています(Excel 2007,2010,2016で確認)。

　これも API 使うんですね。

結局作った

　こういうときはアレですよ、裏技。裏技で良いんですよ、裏技で。

　以下の条件で作りました。

API を使用しない
関数ひとつ
Range を返す（返せないときは Nothing）

使い方

　セル範囲を選択して、コピーまたはカットをします。

　この状態で関数を実行すると、コピー元の範囲の Range オブジェクトを返します。選択された状態の範囲がなければ Nothing を返します。

ソースコード

Option Explicit

Function GetCutCopyRange() As Range
    ' カット・コピー状態でなければ Nothing を返す
    Set GetCutCopyRange = Nothing
    If Application.CutCopyMode <= 0 Then Exit Function
    
    ' 現在の状態を保持する
    Dim savedCondition As Boolean
    savedCondition = ActiveWorkbook.Saved
    
    On Error GoTo ERROR_EXIT
    ' 表示更新を一時停止する
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ' リンク図としてペーストする
    Dim dummy As Variant
    Set dummy = ActiveSheet.Pictures.Paste(Link:=True)
    
    ' リンク図からリンク先を取得する（リンク図は不要になるので削除する）
    Dim f As String
    f = dummy.Formula
    dummy.Delete
    
    ' リンク先からアドレス他を取得する
    f = Replace(f, "=", "", 1, 1)
    
    Dim wb As Workbook, ws As Worksheet
    Set wb = ActiveWorkbook
    Set ws = ActiveSheet
    
    ' 別のワークブックか
    Dim bracketPos As Long, bracketPos2 As Long
    bracketPos = InStr(f, "[")
    bracketPos2 = InStr(f, "]")
    If bracketPos > 0 Then
        Set wb = Workbooks(Mid(f, bracketPos + 1, bracketPos2 - bracketPos - 1))
        f = Mid(f, bracketPos2 + 1)
    End If
    
    ' 別のワークシートか
    Dim exclamationMarkPos As Long
    exclamationMarkPos = InStr(f, "!")
    If exclamationMarkPos > 0 Then
        Set ws = wb.Sheets(Replace(Mid(f, 1, exclamationMarkPos - 1), "'", ""))
        f = Mid(f, exclamationMarkPos + 1)
    End If
    
    ' Range を取得して返す
    Set GetCutCopyRange = ws.Range(f)
ERROR_EXIT:
    ActiveWorkbook.Saved = savedCondition
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Function