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


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

コメント