【Excel VBA】結合セルを作りながら貼り付ける

ソフトウェア開発をしていると、Excel方眼紙というものに出くわすことがある。ありがちな特徴は…
セルが結合されていて、貼り付けに苦労する。
ページ内のタイトルやページ番号をヘッダーとフッター機能を使わず、セルに書かれてあったりするため、改ページまで考慮しないといけなかったりする。

そこで、直接的な解決方法ではないが、コピーしたセルをもとに、貼り付け先に結合セルを作りながら貼り付けるマクロを作成した。
マクロを実行後に作成された結合セルを、手動でExcel方眼紙に対してコピペしていただきたい。

Option Explicit

Public Sub PasteMergedCell()

    Dim src As Range
    Set src = Application.InputBox(Prompt:="変換したいセルを選択してください。", Type:=8)

    Dim dst As Range
    Set dst = Application.InputBox(Prompt:="出力先セル（左上の１セル）を選択してください。", Type:=8)
    
    'マージするセルの大きさ（行数）
    Dim mergeCellRowLength As Integer
    mergeCellRowLength = Application.InputBox(Prompt:="出力先で１行当たりマージするセル数を入力してください。", Type:=1)
    
    'マージするセルの大きさ（列数）
    Dim mergeCellColArray As Variant
    Dim mergeCellColLengthInfo As String
    mergeCellColLengthInfo = Application.InputBox(Prompt:="出力先の列ごとにマージするセル数をカンマ区切りで入力してください。", Type:=2)
    mergeCellColArray = Split(mergeCellColLengthInfo, ",")
        
    Dim srcStartRow As Integer  'コピー開始行
    Dim srcStartCol As Integer  'コピー開始列
    srcStartRow = src.row
    srcStartCol = src.Column
    
    Dim pasteStartRow As Integer    '貼り付け開始行
    Dim pasteStartCol As Integer    '貼り付け開始列
    pasteStartRow = dst.row
    pasteStartCol = dst.Column
        
    Dim pasteTargetRow As Integer   '貼り付け行
    pasteTargetRow = pasteStartRow  '開始行で初期化
    
    Dim pasteTargetCol As Integer   '貼り付け列
    pasteTargetCol = pasteStartCol  '開始列で初期化
    
    '全行ループ
    Dim row As Integer  '現在行
    For row = srcStartRow To srcStartRow + src.Rows.Count - 1
        '変換元を取得
        Dim srcCell As Range
        
        '変換元のある1行の中で最大の行数を取得する
        Dim maxLineCountPerSrcLine As Integer
        maxLineCountPerSrcLine = 0
        
        Dim col As Integer  '現在列
        For col = srcStartCol To srcStartCol + src.Columns.Count - 1
        
            Set srcCell = ActiveSheet.Cells(row, col)   '現在セル

            '変換元の行数を取得
            Dim srcLineCount As Integer
            srcLineCount = UBound(Split(srcCell.Text, vbLf)) + 1    '（セル内改行を取得する）
            
            '貼り付け先の論理行数を算出
            Dim dstLogicalLineCount As Integer
            If srcLineCount < mergeCellRowLength Then
                dstLogicalLineCount = 1
            Else
                dstLogicalLineCount = srcLineCount / mergeCellRowLength
                
                If srcLineCount Mod mergeCellRowLength > 0 Then
                    dstLogicalLineCount = dstLogicalLineCount + 1
                End If
            End If
            
            '貼り付け先の物理行数を算出
            Dim dstPysicalLineCount As Integer
            dstPysicalLineCount = dstLogicalLineCount * mergeCellRowLength
            
            '最大行数を取得する
            If dstPysicalLineCount > maxLineCountPerSrcLine Then
                maxLineCountPerSrcLine = dstPysicalLineCount
            End If
        Next col

        '貼り付け先を作成
        Dim mergeCellColArrayIndex As Integer
        mergeCellColArrayIndex = 0
        
        '１行内の列を貼り付ける
        For col = srcStartCol To srcStartCol + src.Columns.Count - 1
            Set srcCell = ActiveSheet.Cells(row, col)
            
            Dim mergeColLength As Integer
            mergeColLength = mergeCellColArray(mergeCellColArrayIndex)
            
            'セルを結合する
            Dim pasteArea As Range
            Set pasteArea = Range(ActiveSheet.Cells(pasteTargetRow, pasteTargetCol), ActiveSheet.Cells(pasteTargetRow + maxLineCountPerSrcLine - 1, pasteTargetCol + mergeColLength - 1))
            pasteArea.UnMerge   'セルの結合を解除
            
            Application.DisplayAlerts = False  '--- 確認メッセージを非表示
            pasteArea.Merge
            Application.DisplayAlerts = True   '--- 確認メッセージを表示
   
            pasteArea.Value = srcCell.Text
            
            '次の列へ進む
            pasteTargetCol = pasteTargetCol + mergeColLength
            mergeCellColArrayIndex = mergeCellColArrayIndex + 1
        Next col
        
        '貼り付け先を次へ進める
        pasteTargetCol = pasteStartCol
        pasteTargetRow = pasteTargetRow + maxLineCountPerSrcLine
        
    Next row
    
End Sub