MakeCodeGetCellDirect

'MakeCodeGetCellDirect・・・元場所：IkiAddin.ModClipboard
'ClipboardCopy        ・・・元場所：IkiAddin.ModClipboard

Public Sub MakeCodeGetCellDirect()
'選択セル範囲からセルオブジェクトを取得するコード
'直接設定するコードを作成する
'20220610
'20230224 選択したセルに名前定義がある場合はセルのアドレスは定義された名前にする

'例
'「Sheet1」シートの「A1」セルなら「Sheet1.Range("A1")」

    '選択オブジェクトがセルかどうか判定して、セルならセルを参照
    Dim Dummy As Object: Set Dummy = Selection
    Dim Cell  As Range
    If TypeName(Dummy) = "Range" Then
        Set Cell = Dummy
    Else
        Exit Sub
    End If
    
    '選択セルのシートを取得してシートのオブジェクト名を取得
    Dim Sheet         As Worksheet: Set Sheet = Cell.Parent
    Dim SheetCodeNmae As String:    SheetCodeNmae = Sheet.CodeName
    
    '名前定義がされている場合はセルのアドレスは定義した名前を基とする
    Dim CellAddress As String
    Dim CellComment As String
    On Error Resume Next
    Dim CellName As String: CellName = Cell.Name
    On Error GoTo 0
    If CellName <> "" Then
        CellAddress = Cell.Name.Name
        If InStr(CellAddress, "!") > 0 Then
            CellAddress = Split(CellAddress, "!")(1)
        End If
        CellComment = "'" & Cell.Address(False, False)
    Else
        CellAddress = Cell.Address(False, False)
        CellComment = ""
    End If
    
    'コードを作成する
    Dim Str As String
    Str = SheetCodeNmae & "." & "Range(" & """" & CellAddress & """" & ")" & CellComment
        
    '作成したコードをクリップボードに格納
    Call ClipboardCopy(Str)
    
    '音で知らせる
    Call Beep

End Sub

Private Sub ClipboardCopy(ByVal InputClipText As Variant, _
                      Optional ByRef Message As Boolean = False)
'入力テキストをクリップボードに格納
'配列ならば列方向をTabわけ、行方向を改行する。
'20210719作成

'参考:http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/30565154.html

    '入力した引数が配列か、配列の場合は1次元配列か、2次元配列か判定
    Dim HairetuHantei As Long
    Dim Jigen1        As Long
    Dim Jigen2        As Long
    If IsArray(InputClipText) = False Then
        '入力引数が配列でない
        HairetuHantei = 0
    Else
        On Error Resume Next
        Jigen2 = UBound(InputClipText, 2)
        On Error GoTo 0
        
        If Jigen2 = 0 Then
            HairetuHantei = 1
        Else
            HairetuHantei = 2
        End If
    End If
    
    'クリップボードに格納用のテキスト変数を作成
    Dim Output As String
    Dim I      As Long
    Dim J      As Long
    Dim M      As Long
    Dim N      As Long
    
    If HairetuHantei = 0 Then '配列でない場合
        Output = InputClipText
    ElseIf HairetuHantei = 1 Then '1次元配列の場合
    
        If LBound(InputClipText, 1) <> 1 Then '最初の要素番号が1出ない場合は最初の要素番号を1にする
            InputClipText = Application.Transpose(Application.Transpose(InputClipText))
        End If
        
        N = UBound(InputClipText, 1)
        
        Output = ""
        For I = 1 To N
            If I = 1 Then
                Output = InputClipText(I)
            Else
                Output = Output & vbLf & InputClipText(I)
            End If
            
        Next I
    ElseIf HairetuHantei = 2 Then '2次元配列の場合
        
        If LBound(InputClipText, 1) <> 1 Or LBound(InputClipText, 2) <> 1 Then
            InputClipText = Application.Transpose(Application.Transpose(InputClipText))
        End If
        
        N = UBound(InputClipText, 1)
        M = UBound(InputClipText, 2)
        
        Output = ""
        
        For I = 1 To N
            For J = 1 To M
                If J < M Then
                    Output = Output & InputClipText(I, J) & Chr(9)
                Else
                    Output = Output & InputClipText(I, J)
                End If
                
            Next J
            
            If I < N Then
                Output = Output & Chr(10)
            End If
        Next I
    End If
    
    
    'クリップボードに格納'参考 https://www.ka-net.org/blog/?p=7537
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = Output
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With

    '格納したテキスト変数をメッセージ表示
    If Message Then
        MsgBox ("「" & Output & "」" & vbLf & _
                "をクリップボードにコピーしました。")
    End If
    
End Sub