【Excel VBA】結合セルを詰めてコピーペーストするマクロ

近頃はマクロ制作のお仕事をよくいただきます。ありがとうございます。

先日いただいたお仕事で資料としてお預かりしたエクセルブックが「エクセル方眼紙」になっていて、セルのデータをコピーペーストしようとすると空欄が盛大に入ってくるので、なんとも扱いにくかったのでこのマクロを作りました。

上の例のように3列のつもりで扱うと大変なことになってしまいます。

そこでマクロ。まずはメインのコード。

Sub Main()
    Dim add
    add = Split(Replace(Selection.Address, “$”, “”), “:”)
    
    Dim r, col
    r = getMergeRowsCount(add)
    col = getMergeColumnsCount(add)
    
    Dim rowCnt, colCnt
    rowCnt = UBound(r)
    colCnt = UBound(col)
    
    Debug.Print “area start address: “, add(0)
    Debug.Print “area end address: “, add(1)
    Debug.Print “rows count: “, rowCnt
    Debug.Print “columns count: “, colCnt
    Debug.Print
    
    Dim data
    ReDim data(rowCnt, colCnt)
    Dim i, j
    For i = 0 To UBound(r)
        For j = 0 To UBound(col)
            data(i, j) = Cells(r(i), col(j)).Value
        Next j
    Next i
    
    Call putData(data)
End Sub

メインから呼び出している3つのプロシージャ。2つは結合の主体となっているセルの行列番号を特定するためのもの。最後の一つはとりあえず新しいシートを追加してデータを貼り付けたのち、それをコピーしてクリップボードに取り込むためのもの。

Private Function getMergeRowsCount(add) As Variant
    Dim r
    ReDim r(0)
    r(0) = Range(add(0)).Row
    
    Dim inc, j: j = 0
    Do While r(j) <= Range(add(1)).Row
        Debug.Print “rows ” & j; “: ” & r(j)
        inc = Cells(r(j), Range(add(0)).Column).MergeArea.Rows.Count
        j = j + 1
        ReDim Preserve r(j)
        r(j) = r(j – 1) + inc
    Loop
    
    If UBound(r) > j – 1 Then
        ReDim Preserve r(j – 1)
    End If
    
    getMergeRowsCount = r
End Function

Private Function getMergeColumnsCount(add) As Variant
    Dim col
    ReDim col(0)
    col(0) = Range(add(0)).Column
    
    Dim inc, i: i = 0
    Do While col(i) <= Range(add(1)).Column
        Debug.Print “columns ” & i; “: ” & col(i)
        inc = Cells(Range(add(0)).Row, col(i)).MergeArea.Columns.Count
        i = i + 1
        ReDim Preserve col(i)
        col(i) = col(i – 1) + inc
    Loop
    
    If UBound(col) > i – 1 Then
        ReDim Preserve col(i – 1)
    End If
    
    getMergeColumnsCount = col
End Function

Private Sub putData(data)
    Worksheets.add
    
    Dim myName As String
    myName = ActiveSheet.Name
    
    With Sheets(myName)
        .Activate
        Dim nr, ncol
        nr = Selection.Row
        ncol = Selection.Column
        Dim myRange As Range
        Set myRange = .Range(.Cells(nr, ncol), .Cells(nr + UBound(data, 1), ncol + UBound(data, 2)))
        With myRange
            .Value = data
            .Copy
        End With
    End With
    
    ‘ Application.DisplayAlerts = False
    ‘ Sheets(myName).Delete
    ‘ Application.DisplayAlerts = True
End Sub

最後のところで追加したシートを削除しておこうと思ったんですけど、コピーした後に余計なことをするとコピーペーストモードが解除されてしまって貼り付けできないので、仕方なくそのままです。どこかにデータを貼り付け後に手動でシート削除してください（笑）
このマクロを使うと先ほどの上の画像の貼り付け結果もこの通り。