EXCEL VBAでのセル高の範囲指定コピーについて

質問

いつも活用させて頂いております。

ExcelのVBAで、範囲指定したセルのコピーを行い、コピー先のセルに
コピー元のセルの高さをコピーさせるロジックを組みました。

始めは、範囲指定してセル高もコピーしようとしたのですが、
上手く行かなかったので、現在は、ループさせて1行ずつ行っています。

できれば、範囲指定して一括で行いたいのですが、
そのような事は可能なのでしょうか？

ご教授願います。

回答No.1

a-kuma · ベストアンサー

行が連続しているのであれば、

Rows("10:15").RowHeight = 20

こんな感じで、行10～15のセルの高さが 20mm になります。

補足

早速のご回答、ありがとうございます。

確かに、同じ高さにするのであれば、上記のロジックでできるのですが、
コピー元のセル高を貼付け先のセルに反映させたいので、
申し訳ないのですが、上記のロジックでは実現できません。

現在の手順を以下に示します。（全てVBA）
1.コピー元を範囲選択する。
2.貼付け先セルを選択して、貼付けをする。
3.ループさせて、コピー元のセルの高さを貼付け先のセルの高さに1行ずつ反映させる。

この3.の部分をループでなく、1命令で行う事はできないのでしょうか？

回答No.4

nishi6

下記マクロを作ってみました。同一シートのみで可能です。標準モジュールに貼り付けます。
ショートカットキー Ctrl+Shift+A 等に割り当てて下さい。
コピー元を選択し、コントロールキーを押しながらコピー先の左上セルを選択します
順番は逆でもかまいません。複数セルが含まれる矩形セル範囲と単一のセルが指定されていることが要件です。
（これは単一セルと単一セルのコピーと他シートへのコピーは対応していません。）
参考にして下さい。

Public Sub copyExt()
Dim rg As Range '選択セルが要件を満たしているか調べるワーク変数
Dim rgSelect(2) As Range '選択セル、rgSelect(1)をrgSelect(2)に貼り付ける
'*** 選択の検証 ***
If Selection.Areas.Count <> 2 Then 'セルの選択方法の確認（2個？）
MsgBox "セル選択方法が不正です。" & vbCrLf & "（セル範囲が２個でない）"
Exit Sub
End If
With Selection
If .Areas(1).Count = 1 And .Areas(2).Count = 1 Then
MsgBox "単一セル同士のコピーはできません。m(_ _)m"
Exit Sub
End If
If .Areas(1).Count = 1 Then 'セルの選択方法の確認（片方は単一セル？）
Set rgSelect(1) = .Areas(2): Set rgSelect(2) = .Areas(1)
ElseIf .Areas(2).Count = 1 Then
Set rgSelect(1) = .Areas(1): Set rgSelect(2) = .Areas(2)
Else
MsgBox "セル選択方法が不正です。" & vbCrLf & "（片方は単一セルにします）"
Exit Sub
End If
End With
'*** コピー実行 ***
rgSelect(1).Select: Selection.Copy 'コピー
rgSelect(2).Select: ActiveSheet.Paste '貼り付け
'*** 行高を一致させる ***
Application.ScreenUpdating = False '画面の表示更新を禁止
Dim rw As Long '行カウンタ
Dim rwHght1, rwHght2 As Single '行高
For rw = rgSelect(1).Rows.Count To 1 Step -1
rwHght1 = rgSelect(1).Rows(rw).RowHeight '元の行高
rwHght2 = rgSelect(2).Rows(rw).RowHeight 'コピー先の行高
If rwHght1 <> rwHght2 Then
rgSelect(2).Rows(rw).RowHeight = rwHght1 '行高を同じにする
End If
Next
Application.ScreenUpdating = True '画面の表示更新を可にする
End Sub

回答No.3

yanmaa

指定範囲をコピーして、その後行の書式コピーで有れば出来ますが、あまり言い方法ではないですね。
例えば行２～６を行８～１２に高さを設定する方法(書式コピー)
Rows("2:6").Select
Application.CutCopyMode = False
Selection.Copy
Rows("8:12").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= False, Transpose:=False

回答No.2

a-kuma

> ループでなく、1命令で行う事はできないのでしょうか？

そうか、高さはばらばらだったんですね。多分できないと思います。
Range には、それに該当するプロパティが無い。

先の回答で紹介した RowHeight は、選択範囲のセルがばらばらの
高さの場合には Null を返すので、代入する意味が有りません。