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

スポンサーリンク

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

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

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

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

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

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

[vb]
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
[/vb]
 

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

[vb]
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
[/vb]
 

[vb]
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
[/vb]
 

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

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

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

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

 

コメント

タイトルとURLをコピーしました