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

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

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

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

ご教授願います。

このQ&Aに関連する最新のQ&A

A 回答 (4件)

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



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

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

この回答への補足

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

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

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

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

補足日時:2001/05/15 14:33
    • good
    • 0

下記マクロを作ってみました。

同一シートのみで可能です。標準モジュールに貼り付けます。
ショートカットキー 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
    • good
    • 0

指定範囲をコピーして、その後行の書式コピーで有れば出来ますが、あまり言い方法ではないですね。


例えば行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
    • good
    • 0

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



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

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

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qエクセルのマクロで範囲指定をセルに番号を入れて、範囲指定したセルの字の

エクセルのマクロで範囲指定をセルに番号を入れて、範囲指定したセルの字の色を白にして消したいのですが、番号を入れるマクロがわかりません。マクロに記録でA2からB12までのセル内の字の色を白

にする方法は

Sub 字を消す()
'
' 字を消す Macro
'

'
Range("A2:B11").Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
End SubでできるのですがD3に開始番号、E3に終了番号を指定する方法がわかりません。ご教授お願いします

Aベストアンサー

>D3に開始番号、E3に終了番号を指定する方法がわかりません。
 ⇒マクロ記録でD3、E3を選択すればコード化されますが、開始/終了番号での振舞はご自身でコード化しない限り、マクロ記録では設定できません。 
  多分、D3、E3に入力される情報によって、対象範囲の該当セルフォント色を変更したいという事ではないでしょうか。
  ならば、D3,E3セルに入力する情報と対象範囲との関連付けを明示しないと問題解決しませんのでこの質問は一旦締めて、再質問しては如何でしょうか。

Q範囲指定内のセルを行ごとに結合させるアイコンを表示させたい。

こんにちは。いつもお世話になってます。

エクセル2003で、範囲指定(例えば2列以上2行以上)してその中を1行1セルに一括で変えるアイコンをツールバーに表示させたいのですが、どこにあるか教えて下さい。

エクセル2000では、すぐに見つけられたんですが。。

よろしくお願いします。

Aベストアンサー

ツールバーの
ユーザー設定
コマンド
書式
の中に、セルの結合というのがあります

Qセルの指定範囲の所に、他のセルの値を反映させる方法

A1からA10に数字のデータが入っています。
その範囲でLARGE関数を使って1番大きな値を求めようと
B1セルに数式「LARGE(A1:A10,1)」と入れてあります。

ここでC1セルに1から10までのどれかを入れると
「LARGE(A1:A○,1)」
○の部分にC1のデータが反映される、
もしくは同様の結果にすることができる方法はないでしょうか?
よろしくお願いします。

Aベストアンサー

OFFSET関数を使うことで、できそうですけど。
B1セルに =LARGE(OFFSET(A1,0,0,C1,1),1)
C1セルに1から10までの値を入れるとする。

参考にしたのはこちらです。
http://arena.nikkeibp.co.jp/lecture/excel36/20020411/01/

Q範囲指定したセル中のカーソルを合わせたセルに指定した数値を足していくVBA

エクセル2010を使っている者です。
「Color = 13434828」と色を設定したセル範囲においては、カーソルを合わせたセルに、キーボード上の数字をクリックするとその数字が足されるというマクロを作ることは可能ですか?

伝票を見ながら1か月分のデータを集計しようと思っているのですが、そのマクロがあると作業がはかどります。

どなかたよろしくお願いいたします。

Aベストアンサー

No.5です。
>セルを移動させて戻らないと連続して同じセルに加算されない点はなんとかならないのでしょうか。

こちらの環境では正しく動作しているのですが・・・
ブックを開いた時の最初の1回だけかと思っていましたが、全部のセルで同じ状況だと
2番目のプロシージャの動作に問題があります。
エラーが出て止まることはないですよね?
1番目のプロシージャでイベントを制御しているので、そこでエラーが出ると動作しなくなります。
とりあえず2度目からも起動しなくなると言うことですので、一旦コードをすべて消して、
Dim MySum As Variant 
と2番目のプロシージャだけの状態にして、
Private Sub Worksheet_SelectionChange(ByVal Target As Range) の下の行に
MsgBox "SelectionChangeイベント"    '追加-----①
End Withの下の行に
MsgBox "セルの値は" & MySum      '追加-----②
この2行を追加してください。これでプロシージャが状況が分かります。
セルの範囲が変更になると①番目のメッセージがでるので動作していることが分かります。
特定色を選択した場合と特定色のセルに入力したときに②にセルの値が表示されます。
空白の場合は、値は表示されませんがメッセージだけは表示されます。
②が表示されない場合は、特定色のセルでは無いか、コードに問題があります。
①が表示されない場合は、プロシージャが実行されていないということになります。
正しく動作しているようでしたら、1番目のプロシージャを貼り付けて同じように確認してください。
動作しているようなら、特定色のセル以外にカーソルを移動させて保存してブックを閉じてください。
再度ブックを開いて、特定色セルで加算されるか確認してください。
この二つが動作していれば加算されます。
3番目とPrivate Sub Workbook_Open()のコードは、動作の確認できたら貼り付けてください。
Private Sub Workbook_Open()のコードは保存してからブックを閉じて、次に開いた時に実行されます。

>3つめのプロシージャの意図はどういったものなのでしょうか?

セル内での編集を禁止しています。あと編集の途中で他のセルをクリックすると
加算されるのを防ぐためです。
これに関しては、必要なければ消しても構いません。
あとIF文ですが、単一行形式の構文はEnd Ifがありません。

No.5です。
>セルを移動させて戻らないと連続して同じセルに加算されない点はなんとかならないのでしょうか。

こちらの環境では正しく動作しているのですが・・・
ブックを開いた時の最初の1回だけかと思っていましたが、全部のセルで同じ状況だと
2番目のプロシージャの動作に問題があります。
エラーが出て止まることはないですよね?
1番目のプロシージャでイベントを制御しているので、そこでエラーが出ると動作しなくなります。
とりあえず2度目からも起動しなくなると言うことですので、一旦コードをす...続きを読む

QExcelで数式の範囲指定の数値を4ずつ増加させる

A1=min(B1:B4)
A2=min(B5:B8)
A3=min(B9:B12)





上記のような形で数式を並べたいのですが、
数式内の数値を上記のように加算する方法が見つかりません。
どなたかよい方法をご存じないでしょうか?

ちなみに現在はオートフィルで1ずつ増加させたのちに、
他の場所にコピーし、フィルタで邪魔なものを削除し、また貼り付けるという方法をとっています。
これだと手間がかかるので、さらに簡単な方法をお知りの方、アドバイス宜しくお願いします。

Aベストアンサー

A1セルに次の式を入力して下方にドラッグコピーします。

=MIN(INDIRECT("B"&ROW(A1)*4-3):INDIRECT("B"&ROW(A1)*4))


人気Q&Aランキング

おすすめ情報