【知らなくても使える】セル内の最初または最後に指定した値を貼り付けるアドイン（Excel VBA）

Option Explicit

'-----（設定値）------------------------
Private Const PLACE_FIRST = "1"         '１．セルの最初（貼り付け位置）
Private Const PLACE_END = "2"           '２．セルの最後（貼り付け位置）
Private Const SELECT_CELL = "1"         '３．セルからコピー（コピーする値）
Private Const SELECT_WORD = "2"         '４．指定文字（コピーする値）
'---------------------------------------

Private RbRibbon As IRibbonUI           'リボン
Private SetPlace As String              '貼り付け位置
Private SetCopyType As String           '貼り付ける値
Private SpecifiedWord As String         '指定文字（コピーする値）
Private CellValue As String             'コピーしたセルの値（コピーする値）

'===================================
'リボンの初期処理
'===================================
Sub onLoad(ribbon As IRibbonUI)

    'リボンの表示を更新できるようにするためにリボンをセットする
    Set RbRibbon = ribbon
    RbRibbon.Invalidate
    SetPlace = PLACE_FIRST          '初期値：貼り付け位置　セルの最初
    SetCopyType = SELECT_CELL       '初期値：貼り付ける値　セルからコピー
    
End Sub

'===================================
'セル内に貼り付ける際の処理
'===================================
Sub Paste_onClick(control As IRibbonControl)

    Dim tmpValueArr() As Variant
    Dim cntRow As Long, cntCol As Long, i As Long, j As Long
    Dim tmpValue As String

    Dim c As Range
    Set c = Selection
    
    Dim obj As Object
    Set obj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        
    '貼り付ける値をセルからコピーとした場合
    If SetCopyType = SELECT_CELL Then

        obj.GetFromClipboard
        
        'クリップボードのコピーデータが存在する場合
        If obj.GetFormat(1) Then
        
            '最後の改行を取り除く処理
            CellValue = TrimLWord(obj.getText)
            
        Else
            CellValue = ""
        End If
        
        Dim arrTabSpecifiedWord As Variant
        Dim arrLFSpecifiedWord As Variant
        
        arrLFSpecifiedWord = Split(CellValue, vbCrLf)
        
        'クリップボードにある値において改行の数だけ繰り返す
        For i = 0 To UBound(arrLFSpecifiedWord)
        
            arrTabSpecifiedWord = Split(arrLFSpecifiedWord(i), vbTab)
            
            'クリップボードにある値においてタブの数だけ繰り返す
            For j = 0 To UBound(arrTabSpecifiedWord)
            
                'セル内改行がある場合はダブルクォーテーションが存在するので取り除く処理
                arrTabSpecifiedWord(j) = TrimDQ(arrTabSpecifiedWord(j))
                
                If SetPlace = PLACE_FIRST Then
                    ActiveSheet.Cells(c.Row + i, c.Column + j).Value = arrTabSpecifiedWord(j) & ActiveSheet.Cells(c.Row + i, c.Column + j).Value
                Else
                    ActiveSheet.Cells(c.Row + i, c.Column + j).Value = ActiveSheet.Cells(c.Row + i, c.Column + j).Value & arrTabSpecifiedWord(j)
                End If
            Next
        Next
            
    '貼り付ける値を指定文字にした場合
    Else
    
        '指定文字に値がなければ処理を終了する
        If SpecifiedWord = "" Then
            Exit Sub
        End If
        
        '貼り付ける際に選択されたセルが一つの場合は単純に貼り付ける
        If Selection.Cells.Count = 1 Then
            
            If SetPlace = PLACE_FIRST Then
                c.Value = SpecifiedWord & c.Value
            Else
                c.Value = c.Value & SpecifiedWord
            End If
        
        '貼り付ける際に選択されたセルが複数の場合は全てのセルに指定文字を貼り付ける
        Else
            tmpValueArr = c.Value
            cntRow = UBound(tmpValueArr)
            cntCol = UBound(tmpValueArr, 2)
        
            For i = 1 To cntRow
                For j = 1 To cntCol
        
                    If SetPlace = PLACE_FIRST Then
                        tmpValueArr(i, j) = SpecifiedWord & tmpValueArr(i, j)
                    Else
                        tmpValueArr(i, j) = tmpValueArr(i, j) & SpecifiedWord
                    End If
        
                Next
            Next
            c.Value = tmpValueArr
            
        End If
    End If
    
End Sub

'===================================
'貼り付け位置（セルの最初、セルの最後）を選択した際の処理
'===================================
Sub TglPaste_onSel(control As IRibbonControl, pressed As Boolean) ' トグルボタンのクリック処理

    Select Case control.ID
    
        Case "tglBtn_pasteFirst"      'セルの最初を選択した場合
            SetPlace = PLACE_FIRST
        
        Case "tglBtn_pasteEnd"        'セルの最後を選択した場合
            SetPlace = PLACE_END
        
    End Select
    
    RbRibbon.InvalidateControl ("tglBtn_pasteFirst")
    RbRibbon.InvalidateControl ("tglBtn_pasteEnd")
End Sub

'-------------------------
'貼り付け位置を変更する際に行われる処理
'-------------------------
Sub TglPaste_getPressed(control As IRibbonControl, ByRef returnedVal)

    Select Case control.ID
    
        Case "tglBtn_pasteFirst"    'セルの最初を選択した場合
        
            If SetPlace = "" Then
                returnedVal = True
            Else
                If SetPlace = PLACE_FIRST Then
                    returnedVal = True
                Else
                    returnedVal = False
                End If
            End If
        
        Case "tglBtn_pasteEnd"      'セルの最後を選択した場合
            
            If SetPlace = "" Then
                returnedVal = False
            Else
                If SetPlace = PLACE_END Then
                    returnedVal = True
                Else
                    returnedVal = False
                End If
            End If
        
    End Select
    
End Sub

'===================================
'貼り付ける値（セルからコピー、指定文字）を選択した際の処理
'===================================
Sub TglPoint_onSel(control As IRibbonControl, pressed As Boolean)

    Select Case control.ID
        
        Case "tglBtn_tgtCell"               'セルからコピーを選択した場合
            SetCopyType = SELECT_CELL
        
        Case "tglBtn_tgtWord"               '指定文字を選択した場合
            SetCopyType = SELECT_WORD
        
    End Select
    
    RbRibbon.InvalidateControl ("tglBtn_tgtCell")
    RbRibbon.InvalidateControl ("tglBtn_tgtWord")
    RbRibbon.InvalidateControl ("edbox_tgtWord")
End Sub

'-------------------------
'貼り付ける値を変更する際に行われる処理
'-------------------------
Sub TglCopy_getPressed(control As IRibbonControl, ByRef returnedVal)

    Select Case control.ID
    
        Case "tglBtn_tgtCell"       'セルからコピーを選択した場合
        
            If SetCopyType = "" Then
                returnedVal = True
            Else
                If SetCopyType = SELECT_CELL Then
                    returnedVal = True
                Else
                    returnedVal = False
                End If
            End If
        
        Case "tglBtn_tgtWord"       '指定文字を選択した場合
        
            If SetCopyType = "" Then
                returnedVal = False
            Else
                If SetCopyType = SELECT_WORD Then
                    returnedVal = True
                Else
                    returnedVal = False
                End If
            End If
        
    End Select
    
End Sub

'-------------------------
'指定文字のテキスト内容を取得する際の処理
'-------------------------
Sub TgtWord_getText(control As IRibbonControl, ByRef returnValue)
    '初期値なし
End Sub

'-------------------------
'指定文字に変更があった際の処理
'-------------------------
Sub TgtWord_onChange(control As IRibbonControl, text As String)
    SpecifiedWord = text
End Sub

'-------------------------
'指定文字の活性/非活性を変更する処理
'-------------------------
Sub TgtWord_getEnabled(control As IRibbonControl, ByRef returnedVal)
    If SetCopyType = "" Or SetCopyType = SELECT_WORD Then
        returnedVal = True
    Else
        returnedVal = False
    End If
End Sub

'-------------------------
'汎用処理：文字列の最後に改行があれば取り除く
'-------------------------
Function TrimLWord(strTmp As String)

    If Right(strTmp, 1) = vbLf Then
        strTmp = Left(strTmp, Len(strTmp) - 2)
    End If
    
    TrimLWord = strTmp
    
End Function

'-------------------------
'汎用処理：ダブルクォーテーションを取り除く（セル内改行の場合）
'-------------------------
Function TrimDQ(strTmp As Variant)

    If InStr(strTmp, vbLf) > 0 And Right(strTmp, 1) = """" And Left(strTmp, 1) = """" Then
        
        strTmp = Left(strTmp, Len(strTmp) - 1)
        strTmp = Right(strTmp, Len(strTmp) - 1)
        strTmp = Replace(strTmp, """""", """")
        
    End If
    
    TrimDQ = strTmp
    
End Function