【知らなくても使える】Excel標準機能では実現できない様々な貼り付けができるアドイン（Excel VBA）

Option Explicit

'-----（設定値）------------------------
Private Const SEPARATE_VALUE = ","      '１．区切り文字の初期値
'---------------------------------------

Private SepValue As String              '区切り文字

'===================================
'一つのセルに貼り付けをした際の処理
'===================================
Sub OneCellPaste_onClick(control As IRibbonControl)

    Dim c As Range
    Set c = Selection
    
    Dim clipboardValue As Variant
    clipboardValue = GetClipBoard
    
    clipboardValue = Replace(clipboardValue, vbCrLf, vbLf)
    clipboardValue = Replace(clipboardValue, Chr(9), SepValue)
    c.Value = clipboardValue

End Sub

'===================================
'複数のセルに分割して貼り付けをした際の処理
'===================================
Sub SplitPaste_onClick(control As IRibbonControl)

    Dim i As Long, j As Long
    Dim c As Range
    Set c = Selection
    
    Dim clipboardValue As Variant
    clipboardValue = GetClipBoard
    
    Dim arrTabSpecifiedWord As Variant
    Dim arrLFSpecifiedWord As Variant
    
    clipboardValue = Replace(clipboardValue, vbCrLf, vbLf)
    clipboardValue = Replace(clipboardValue, vbCr, vbLf)
    arrLFSpecifiedWord = Split(clipboardValue, vbLf)

    'クリップボードにある値において改行の数だけ繰り返す
    For i = 0 To UBound(arrLFSpecifiedWord)

        arrTabSpecifiedWord = Split(arrLFSpecifiedWord(i), SepValue)

        'クリップボードにある値において「区切り文字」の数だけ繰り返す
        For j = 0 To UBound(arrTabSpecifiedWord)

            ActiveSheet.Cells(c.Row + i, c.Column + j).Value = arrTabSpecifiedWord(j)

        Next
    Next
    
End Sub

'===================================
'行と列を入れ替えて貼り付けをした際の処理
'===================================
Sub Rowcol_Replace_onClick(control As IRibbonControl)

    Dim c As Range
    Set c = Selection
    
    Dim clipboardValue As Variant
    clipboardValue = GetClipBoard
    
    clipboardValue = Replace(clipboardValue, SepValue, Chr(8))  '区切り文字をバックスペース文字にいったん退避させる
    clipboardValue = Replace(clipboardValue, Chr(9), Chr(8))    'タブをバックスペース文字にいったん退避させる

    clipboardValue = Replace(clipboardValue, vbCrLf, SepValue)  'セルをまたぐ改行を区切り文字に変換する
    clipboardValue = Replace(clipboardValue, vbLf, SepValue)    'セル内の改行を区切り文字に変換する
    
    clipboardValue = Replace(clipboardValue, Chr(8), vbCrLf)    'バックスペース文字をセルをまたぐ改行に変換する
    
    c.Value = clipboardValue
    
End Sub

'===================================
'逆転させて貼り付けをした際の処理
'===================================
Sub ReversePaste_onClick(control As IRibbonControl)

    Dim i As Long, j As Long
    Dim c As Range
    Set c = Selection
    
    Dim clipboardValue As Variant
    clipboardValue = GetClipBoard
    
    Dim arrLFSpecifiedWord As Variant
    Dim arrTabSpecifiedWord As Variant
    
    arrLFSpecifiedWord = Split(clipboardValue, vbCrLf)
    arrLFSpecifiedWord = GetReverseValue(arrLFSpecifiedWord)

    'クリップボードにある値において改行の数だけ繰り返す
    For i = 0 To UBound(arrLFSpecifiedWord)

        arrTabSpecifiedWord = Split(arrLFSpecifiedWord(i), Chr(9))
        arrTabSpecifiedWord = GetReverseValue(arrTabSpecifiedWord)

        'クリップボードにある値において「区切り文字」の数だけ繰り返す
        For j = 0 To UBound(arrTabSpecifiedWord)

            ActiveSheet.Cells(c.Row + i, c.Column + j).Value = arrTabSpecifiedWord(j)

        Next
    Next
    
End Sub

'-------------------------
'区切り文字のテキスト内容を取得する際の処理
'-------------------------
Sub Edtb_getText(control As IRibbonControl, ByRef returnValue)
    SepValue = SEPARATE_VALUE
    returnValue = SepValue
End Sub

'-------------------------
'区切り文字に変更があった際の処理
'-------------------------
Sub Delimiter_onChange(control As IRibbonControl, text As String)
    SepValue = text
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, Chr(34) & Chr(34)) > 0 Then
        
        'セル内のダブルクォーテーションをバックスペース文字にいったん退避させる
        strTmp = Replace(strTmp, Chr(34) & Chr(34), Chr(8))
        
        'ダブルクォーテーションを取り除く
        strTmp = Replace(strTmp, Chr(34), "")
        
        'バックスペース文字をダブルクォーテーションに変換する
        strTmp = Replace(strTmp, Chr(8), Chr(34))
    
    Else
        
        'ダブルクォーテーションをなくす
        strTmp = Replace(strTmp, Chr(34), "")
    
    End If
    
    TrimDQ = strTmp
    
End Function

'-------------------------
'汎用処理：クリップボードの中の値を取得する
'-------------------------
Function GetClipBoard()
    
    Dim tmpValue As Variant
    
    Dim obj As Object
    Set obj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
    obj.GetFromClipboard
    
    'クリップボードのコピーデータが存在する場合
    If obj.GetFormat(1) Then
    
        '最後の改行を取り除く処理
        tmpValue = TrimLWord(obj.getText)
        
        'セル内のダブルクォーテーションを取り除く処理
        tmpValue = TrimDQ(tmpValue)
        
    Else
        tmpValue = ""
    End If
    
    GetClipBoard = tmpValue
    
End Function

'-------------------------
'汎用処理：配列の値を逆にする
'-------------------------
Function GetReverseValue(arrTmp As Variant)

    If IsArray(arrTmp) = False Then
        GetReverseValue = arrTmp
    End If
    
    Dim iStart As Long: iStart = LBound(arrTmp)     '配列の最初
    Dim iEnd As Long: iEnd = UBound(arrTmp)         '配列の最後
    Dim tempValue
    
    Do
        '添え字の大小が逆転もしくは一致した場合はループ終了
        If iStart >= iEnd Then
            Exit Do
        End If
        
        '配列要素の入れ替え
        tempValue = arrTmp(iStart)
        arrTmp(iStart) = arrTmp(iEnd)
        arrTmp(iEnd) = tempValue
        
        iStart = iStart + 1
        iEnd = iEnd - 1
    Loop
    
    GetReverseValue = arrTmp

End Function