VBA,関数
解決済
回答 2
投稿
- 評価
- クリップ 0
- VIEW 2,228
エクセルでセル枠に大きい写真を自動で枠にピッタリ収まるようにしたいです。
このVBAにボタンを作成してもうまくいきません
Sub InsertPictures()
Dim i As Integer
Dim myDir As String
Const myHeight = 200 '行の高さ。0-409を指定。写真のサイズがこれで調整される。
Const myWidth = 50 '列の幅。0 - 255を指定。
Dim myFName As String
myDir = Application.GetOpenFilename(FileFilter:="すべての図(*.jpg),*.jpg")
If myDir = "False" Then Exit Sub
myDir = Left(myDir, Len(myDir) - Len(Dir(myDir)))
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
Columns(2).ClearContents
Rows.AutoFit
i = 1
myFName = Dir(myDir & "*.jpg")
Do While myFName <> ""
With Cells(i, 1)
.Activate
.RowHeight = myHeight
End With
With ActiveSheet
.Pictures.Insert myDir & myFName
With .Shapes(i)
.LockAspectRatio = msoTrue
.Height = myHeight
End With
End With
Cells(i, 2).Value = myFName
myFName = Dir
i = i + 1
Loop
Columns(1).ColumnWidth = myWidth
Columns(2).AutoFit
Application.ScreenUpdating = True
End Sub
ご教授ください
-
気になる質問をクリップする
クリップした質問は、後からいつでもマイページで確認できます。
またクリップした質問に回答があった際、通知やメールを受け取ることができます。
クリップを取り消します
-
良い質問の評価を上げる
以下のような質問は評価を上げましょう
- 質問内容が明確
- 自分も答えを知りたい
- 質問者以外のユーザにも役立つ
評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。
質問の評価を上げたことを取り消します
-
評価を下げられる数の上限に達しました
評価を下げることができません
- 1日5回まで評価を下げられます
- 1日に1ユーザに対して2回まで評価を下げられます
質問の評価を下げる
teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。
- プログラミングに関係のない質問
- やってほしいことだけを記載した丸投げの質問
- 問題・課題が含まれていない質問
- 意図的に内容が抹消された質問
- 過去に投稿した質問と同じ内容の質問
- 広告と受け取られるような投稿
評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。
質問の評価を下げたことを取り消します
この機能は開放されていません
評価を下げる条件を満たしてません
質問の評価を下げる機能の利用条件
この機能を利用するためには、以下の事項を行う必要があります。
- 質問回答など一定の行動
-
メールアドレスの認証
メールアドレスの認証
-
質問評価に関するヘルプページの閲覧
質問評価に関するヘルプページの閲覧
checkベストアンサー
0
ご提示のコードのままで、問題なく動きました。
印刷プレビューもしてみましたが、ずれることもないようです。
回答になっていませんが、ご参考までに・・・。
ちなみに「高さ」だけ調整ですよね？「幅」は固定値（50）にされてますので。
ご提示のコードはインデントが見づらいので、下記に貼り付け直します。
Sub InsertPictures()
Dim i As Integer
Dim myDir As String
Const myHeight = 200 '行の高さ。0-409を指定。写真のサイズがこれで調整される。
Const myWidth = 50 '列の幅。0 - 255を指定。
Dim myFName As String
myDir = Application.GetOpenFilename(FileFilter:="すべての図(*.jpg),*.jpg")
If myDir = "False" Then Exit Sub
myDir = Left(myDir, Len(myDir) - Len(Dir(myDir)))
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
Columns(2).ClearContents
Rows.AutoFit
i = 1
myFName = Dir(myDir & "*.jpg")
Do While myFName <> ""
With Cells(i, 1)
.Activate
.RowHeight = myHeight
End With
With ActiveSheet
.Pictures.Insert myDir & myFName
With .Shapes(i)
.LockAspectRatio = msoTrue
.Height = myHeight
End With
End With
Cells(i, 2).Value = myFName
myFName = Dir
i = i + 1
Loop
Columns(1).ColumnWidth = myWidth
Columns(2).AutoFit
Application.ScreenUpdating = True
End Sub投稿
-
回答の評価を上げる
以下のような回答は評価を上げましょう
- 正しい回答
- わかりやすい回答
- ためになる回答
評価が高い回答ほどページの上位に表示されます。
-
回答の評価を下げる
下記のような回答は推奨されていません。
- 間違っている回答
- 質問の回答になっていない投稿
- スパムや攻撃的な表現を用いた投稿
評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。
0
役に立たない回答ですが、EXCELに理想を求めすぎると、挫折します。
EXCEL ＆ Windows では、
１．画面上、見た目正しくても、印刷がずれます。
２．Windows では、最初期のころから(劣化MACと云われた時代から）、
画面解像度と、印刷解像度の整合性を、厳密には考慮していません。
当時のMACは、画面72dpi / 印刷72dpiの倍数 を厳密に守って、
現在とは異なり、画面の１ｃｍ＝印刷の１ｃｍとなるようにシステムの囲い込みをしていました。
⇒当時の超御高いCAD/DTPに比べて、ＭＡＣが安かったので、デザイン系に好まれた。
３．EXCEL は何より、基本は表計算ソフトです、ＤＴＰソフトウェアではありません。
EXCEL 2003 で一様の完成を見た後、グラフィック、画像の扱いでは、
2007/2010/2013/2016 に於いて、OSに絡むだけでは説明しきれない、妙な劣化があります。
※製品としては息が長いのに、余り有名ではありませんが、OFFICE には、
OFFICE Publisher というＤＴＰ製品があります。
※解像度の話では、 dpi / ppi / dppx が使われますが、
画面解像度が同じであれば、ディスプレイサイズにより、dpi は変わるのが本質です。
ただ、Windows PC の場合は、古くより余り意識されていません。
Windowx XP 辺りより、意識され始めて用語が変わって来ましたが、まだまだ。
※Windows では、画面解像度が、96 dpi(本質的には、意味が異なるのですが）を基本としています。
プリンタ側は、144dpi / 160dpi / 180dpi の倍数だったりと、まちまちです。
プリンタの解像度の違いと、画面の解像度の違いは、Windows とプリンタドライバの間で
調整されるはずなのですが、必ずしもそうなっていない例が、
EXCELの画面では、文字、図形が収まっているのに、印刷すると、はみ出す、小さくなる
という事で発現します。
投稿
-
回答の評価を上げる
以下のような回答は評価を上げましょう
- 正しい回答
- わかりやすい回答
- ためになる回答
評価が高い回答ほどページの上位に表示されます。
-
回答の評価を下げる
下記のような回答は推奨されていません。
- 間違っている回答
- 質問の回答になっていない投稿
- スパムや攻撃的な表現を用いた投稿
評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。
15分調べてもわからないことは、teratailで質問しよう！
- ただいまの回答率 88.34%
- 質問をまとめることで、思考を整理して素早く解決
- テンプレート機能で、簡単に質問をまとめられる