-PR-
解決済み

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

  • すぐに回答を!
  • 質問No.76281
  • 閲覧数906
  • ありがとう数1
  • 気になる数0
  • 回答数4
  • コメント数0

お礼率 40% (36/88)

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

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

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

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

ご教授願います。
通報する
  • 回答数4
  • 気になる
    質問をブックマークします。
    マイページでまとめて確認できます。

質問者が選んだベストアンサー

  • 回答No.1
レベル14

ベストアンサー率 50% (1122/2211)

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

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

こんな感じで、行10~15のセルの高さが 20mm になります。
補足コメント
forester

お礼率 40% (36/88)

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

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

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

この3.の部分をループでなく、1命令で行う事はできないのでしょうか?
投稿日時 - 2001-05-15 14:33:19
-PR-
-PR-

その他の回答 (全3件)

  • 回答No.3
レベル12

ベストアンサー率 45% (207/457)

指定範囲をコピーして、その後行の書式コピーで有れば出来ますが、あまり言い方法ではないですね。
例えば行2~6を行8~12に高さを設定する方法(書式コピー)
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
レベル14

ベストアンサー率 50% (1122/2211)

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

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

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

ベストアンサー率 68% (791/1163)

下記マクロを作ってみました。同一シートのみで可能です。標準モジュールに貼り付けます。
ショートカットキー 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 & "(セル範囲が2個でない)"
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
このQ&Aのテーマ
このQ&Aで解決しましたか?
AIエージェント「あい」

こんにちは。AIエージェントの「あい」です。
あなたの悩みに、OKWAVE 3,500万件のQ&Aを分析して最適な回答をご提案します。

関連するQ&A
-PR-
-PR-
このやり方知ってる!同じこと困ったことある。経験を教えて!
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。

その他の関連するQ&A、テーマをキーワードで探す

キーワードでQ&A、テーマを検索する
-PR-
-PR-
-PR-

特集


専門家があなたの悩みに回答!

-PR-

ピックアップ

-PR-
ページ先頭へ