エクセルVBAコードをお願いいたします。


下記は選択した画像を縦横比固定で幅4cmにサイズ調整するマクロです。
このマクロに追加機能をつけて頂きたいのです。
画像に合わせてセルの高さを自動調整する機能です。
列の幅は30固定です。
(だいたい上下2ミリ程度の余白があるのが理想です)

Sub Macro1()

Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = 4 * 100 / 254 * 72

End Sub

何卒よろしくお願い致します。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/11/11 23:55:23
  • 終了:2013/11/12 20:26:36

ベストアンサー

id:windofjuly No.1

うぃんど回答回数2625ベストアンサー獲得回数11492013/11/12 10:46:56

ポイント50pt

Width の元の値を取得しておいて、比率を求める
Dim oldWidth
Selection.ShapeRange.LockAspectRatio = msoTrue
oldWidth = Selection.ShapeRange.Width
Selection.ShapeRange.Width = 4 * 100 / 254 * 72
Selection.ShapeRange.Height = Selection.ShapeRange.Height * ( Selection.ShapeRange.Width / oldWidth )


上下それぞれ2mmなので合計4mm
1ポイント≒0.353mmで計算して11ポイントにしてます。

Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = 4 * 100 / 254 * 72
Rows("1:1").RowHeight = Selection.ShapeRange.Height + 11

※ごめんなさい。引き続き動作確認はしてません。

他7件のコメントを見る
id:tyyyu2005

うぃんどさん
状況説明が足りず大変失礼致しました。

Selection.ShapeRange(1).TopLeftCell.Row
を参照に
ShapeRangeの枚数1枚での動作確認させて頂きました。
ありがとうございました。

次回からはもっと具体的に説明できるように致します。

2013/11/12 20:19:43
id:windofjuly

こちらこそ、もう少し確認してから回答すべきでした。
出来たようで、ほっとしてます…。

2013/11/12 20:29:57

その他の回答(1件)

id:windofjuly No.1

うぃんど回答回数2625ベストアンサー獲得回数11492013/11/12 10:46:56ここでベストアンサー

ポイント50pt

Width の元の値を取得しておいて、比率を求める
Dim oldWidth
Selection.ShapeRange.LockAspectRatio = msoTrue
oldWidth = Selection.ShapeRange.Width
Selection.ShapeRange.Width = 4 * 100 / 254 * 72
Selection.ShapeRange.Height = Selection.ShapeRange.Height * ( Selection.ShapeRange.Width / oldWidth )


上下それぞれ2mmなので合計4mm
1ポイント≒0.353mmで計算して11ポイントにしてます。

Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = 4 * 100 / 254 * 72
Rows("1:1").RowHeight = Selection.ShapeRange.Height + 11

※ごめんなさい。引き続き動作確認はしてません。

他7件のコメントを見る
id:tyyyu2005

うぃんどさん
状況説明が足りず大変失礼致しました。

Selection.ShapeRange(1).TopLeftCell.Row
を参照に
ShapeRangeの枚数1枚での動作確認させて頂きました。
ありがとうございました。

次回からはもっと具体的に説明できるように致します。

2013/11/12 20:19:43
id:windofjuly

こちらこそ、もう少し確認してから回答すべきでした。
出来たようで、ほっとしてます…。

2013/11/12 20:29:57
id:Lhankor_Mhy No.2

Lhankor_Mhy回答回数775ベストアンサー獲得回数2302013/11/12 19:41:27

ポイント50pt

 では、うぃんどさんのコードを引き継いで回答します。。

Sub test()
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Width = 4 * 100 / 254 * 72
    Rows(Selection.TopLeftCell.Row).RowHeight = Selection.ShapeRange.Height + 11
    Selection.Top = Selection.Top + 5.5
End Sub

 excel2003にて、新しいブックを開き画像ひとつを挿入した状態で動作確認。
 ただ、私はうぃんどさんみたいに厳密ではないので、利用方法によっては動かないこともあると思います。その場合はご自分で対処してください。

id:tyyyu2005

Lhankor_Mhyさん
ご回答ありがとうございます。
動作確認させて頂きました。
ありがとうございました。

2013/11/12 20:25:50

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません