人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

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

Sub Macro1()

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

End Sub

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

●質問者: tyyyu2005
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● うぃんど
●50ポイント ベストアンサー

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

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


Lhankor_Mhyさんのコメント
もしかして質問を誤解されているかもしれません。 >> このマクロに追加機能をつけて頂きたいのです。 画像に合わせてセルの高さを自動調整する機能です。 <<

うぃんどさんのコメント
ご指摘感謝です。寝ぼけててすみません。 回答欄のほうで訂正しました。

tyyyu2005さんのコメント
うぃんどさん ご回答ありがとうございます。 動作確認させて頂きました所、画像の幅が縦横比固定で4cmになった所は確認致しました。 すみません。自分の説明が足りなかったかもしれません。 改めて説明させて頂きます。 こちらの希望は ?選択した画像を縦横比固定で幅4cmにリサイズ (すると縦横比固定なので画像の高さも増減があります) ? ?のプロセスにより増減した画像の高さに合わせてセルの高さを調整 (上下余白2mmが理想です) お手数をおかけしてしまい申し訳ございません。 よろしくお願い致します。

うぃんどさんのコメント
一行目の高さは変化しませんでしたか? 残念ながら、私に提示できるのは今回回答させていただいたように、 特定の行(回答では1行目を対象にしています)の変更までです。 なぜなら、ShapeRangeは複数の画像を含むことが出来るためです。 仮に1つだけしか含まれないようにするとしても、 画像とセルとの連携がどうなっていのかなどの情報を拾って対応する必要があるため、 かなり大掛かりな仕掛けとなり、開発には数日みっちりとかかるかもしれないからです。 ご希望に添えず申し訳ありませんが、 キャンセルしていただいたほうがよろしいかと思います。

うぃんどさんのコメント
開発してみたいという人のためにヒントを残しておきます。 下記でShapeRange に含まれている画像の数がわかります。 Selection.ShapeRange.Count 下記でShapeRangeの1つ目の画像の左上がどのセル内にあるかわかります。 Selection.ShapeRange(1).TopLeftCell.Row ループで順次処理すればできそうな気もしますが、ご勘弁を。 なお、キャンセルして新たに整理しなおして質問をやりなおされるなら、 Excelのバージョンくらいは書いておいたほうが良いでしょう。 手作業の手順をスクリーンショットにして投稿につけると、 もしかしたらよい結果が得られるかもしれません。 以上、蛇足でした・・・。

Lhankor_Mhyさんのコメント
あら、このコメントを読む前に回答してしまいました…… 自分の回答こそ蛇足になってしまいましたね

うぃんどさんのコメント
どこまでやる?どこで妥協する?の話なので、 Lhankor_Mhyさんのご回答は蛇足ではないと思います。

tyyyu2005さんのコメント
うぃんどさん 状況説明が足りず大変失礼致しました。 Selection.ShapeRange(1).TopLeftCell.Row を参照に ShapeRangeの枚数1枚での動作確認させて頂きました。 ありがとうございました。 次回からはもっと具体的に説明できるように致します。

うぃんどさんのコメント
こちらこそ、もう少し確認してから回答すべきでした。 出来たようで、ほっとしてます…。

2 ● Lhankor_Mhy
●50ポイント

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

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


tyyyu2005さんのコメント
Lhankor_Mhyさん ご回答ありがとうございます。 動作確認させて頂きました。 ありがとうございました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ