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


Warning: Use of undefined constant user_level - assumed 'user_level' (this will throw an Error in a future version of PHP) in /home/take1mg/www/plus1/wp-content/plugins/ultimate-google-analytics/ultimate_ga.php on line 524

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

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

エクセル方眼紙で作成されたものは大抵セル結合がたっぷり入っています。

そのままコピーしてペーストするとこの通り空欄だらけで、貼り付け先に入力しておいたデータを消してしまうことも…。

上の例のように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

 

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

マクロを使って普通になってくれたデータ

サンプルのファイルはこちらからダウンロードできます。

サンプルファイルのダウンロード

 

コメントを残す

メールアドレスが公開されることはありません。

日本語が含まれない投稿、および宣伝に類する投稿は無視されますのでご注意ください。(スパム対策)