セル結合している複数行にデータをコピペするマクロ【Excel VBA】

'# 結合セルを崩さずに貼りつける機能
  '┗※貼り付け対象のファイルが共有ブックかつ印刷範囲外が
  '   シート保護されいる場合は操作不可
　'┗※コピー範囲の限度列数は48列
'# このマクロ本体以外に「GetCB」Functionが必要

Sub 結合セル突破()

'# 変数宣言
    Dim i        As Long
    Dim cnt      As Long
    Dim str      As String
    Dim oSheet   As String
    Dim r        As Range
    Dim oRange   As Range
    Dim pRange   As Range

'# 貼付先がセル結合の場合
    If ActiveCell.MergeCells Then
   
    '# セルコピーモードの場合
        If Application.CutCopyMode = xlCopy Then

        '# 画面固定および確認メッセージ非表示
            Application.DisplayAlerts = False
            Application.ScreenUpdating = False
        
        '# 貼付先と貼付先シート名を変数に格納
            Set pRange = Selection
            oSheet = ActiveSheet.Name
            
            '# 一時貼付先にコピー元を値貼り付け
              '┗Excel2003の限界列がIV列。そこから48行遡ったHA列に設定
                Range("HA1").Select
                Selection.PasteSpecial xlPasteValues
            '# 貼付した範囲を取得（あとでその範囲を消去するため）
                Set oRange = Selection
            '# 貼付した範囲をコピー。もとの貼り付け先にセル移動
                Selection.Copy
                Sheets(oSheet).Select
                pRange.Select
            '# 貼付した範囲をコピー。もとの貼り付け先にセル移動
                GoSub skip2

                oRange.ClearContents
                
                Sheets(oSheet).Select

        '# 画面固定および確認メッセージ非表示の解除
            Application.DisplayAlerts = True
            Application.ScreenUpdating = True
      
    '# セルコピーでない場合はクリップボードの内容を取得して貼付
        Else
            GoSub skip1
        End If
 
'# 貼付先がセル結合ではない場合
    Else
        On Error Resume Next
        '# セルコピーモードの場合は値貼付。
        If Application.CutCopyMode = xlCopy Then
            Selection.PasteSpecial xlPasteValues
        '# セルコピーでない場合はクリップボードの内容を取得して貼付
        Else
            GoSub skip1
        End If
    End If

Exit Sub

'# 結合セルに値を貼りつけるためのサブルーチン
skip2:
        
        '# 一時貼付先のセル範囲の値を本来の貼り付け先に反映
        cnt = 0
        For Each r In oRange
          
        '# セルが空欄もしくは改行コードのみの場合はスキップ
            If r.Value = "" Then
            ElseIf r.Value = vbLf Then
            Else
                ActiveCell.Select
                If cnt <> 0 Then
                '# コピーが横方向の場合（前周の列番号と今回の番号が異なる場合）に貼付先セル移動
                    If cCnt <> r.Column Then
                        ActiveCell.Offset(0, 1).Select
                '# コピーが縦方向の場合に貼付先セル移動
                    Else
                        ActiveCell.Offset(1, 0).Select
                    End If
                End If
                '# 値を反映
                Selection.Value = r.Value
                cnt = cnt + 1
                cCnt = r.Column
            End If

        Next
        '# 本来の貼り付け先にセルを戻す
        pRange.Select
        Return
        
Exit Sub

'# クリップボードの内容を取得して貼りつけるためのサブルーチン
skip1:

'# クリップボードの値を変数に格納
    Call GetCB(str)
'# クリップボード内の改行コードの数をカウント
    cnt = Len(str) - Len(WorksheetFunction.Substitute(str, vbLf, ""))
    
'# セルが空欄もしくは改行コードのみの場合はスキップ
    If str = "" Then
    ElseIf str = vbLf Then
'# 改行コードがない場合はそのまま反映
    ElseIf cnt = 0 Then
        
        Selection.Value = WorksheetFunction.Clean(str)

'# 改行コードが有る場合は分割して各セルに反映
  '┗一つのセルに格納する分岐も考えたがあまり用途がなさそうなので除外
    Else
        For i = 0 To cnt
            Selection.Offset(i, 0).Value = WorksheetFunction.Clean(Split(str, vbLf)(i))
        Next
    End If
    Return

Exit Sub

ERR1:
    
End Sub
 



'# クリップボードから文字列を取得
Public Sub GetCB(ByRef str As String)
  With CreateObject("Forms.TextBox.1")
    .MultiLine = True
    If .CanPaste = True Then .Paste
    str = .Text
  End With
End Sub

'マクロを「ctrl」 + 「Win」キーに割り当て
Sub mON()
    
    Application.OnKey "^{91}", "結合セル突破"

End Sub

'「ctrl」 + 「Win」キーの割り当てを解除
Sub mOFF()
    
    Application.OnKey "^{91}"

End Sub