こんにちは。宜しくお願いします。
マクロで「セルに入れたファイル名の画像を隣のセルに読み込む」作業を行いたいのですが・・・。うまくいきません。どなたかご助言いただけると助かります。
<内容>
セル内には上から1位・2位と順位通りになっており、その順位に入っているセルのファイル名と一致している画像を隣のセルに読み込みたいと思っています。またファイル名と画像が一致しない場合は「No Image」として1枚の画像を貼り付けることもしたいです。
A(順位) B(名) C(画像)
---------------------------------------------
1 1位 test01 D:\画像\teet01.JPG
2 2位 test02 D:\画像\teet02.JPG
3 3位 test03 D:\画像\teet03.JPG
.
.
.
10 10位 test10 D:\画像\teet10.JPG
<問題点>
・B2の「test01」から順に読み込んでもらいたいのにB1の「名」を読み込んでしまうためエラーが生じる。
・画像をセルの結合した分の大きさに合わせたいのだが、セル1個分のサイズに表示してしまうためうまく調節できない。
<マクロ文>
Private Sub CommandButton1_Click()
Dim i As Long
Dim myPic As Object
Dim myCell As Range
For i = 1 To Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row
Set myCell = Range("C" & i)
Set myPic = ActiveSheet.Pictures.Insert("D:\画像\" & myCell.Value & ".JPG")
With myPic
.Width = Range("D2").Width
.Height = Range("D2").Height
End With
Set myPic = Nothing
Next i
End Sub
色々とネット等を見てはいるのですが・・・うまくいきませんでした。
どこをどのようにして代えればうまく動作するか分かる方いらっしゃいましたら教えていただきたいです。宜しくお願い致します。
No.2ベストアンサー
- 回答日時:
倍率の変更もですが、それより Top 位置の調整が必要です。
Sub try_2()
Const n As Long = 2 'margin
Dim r As Range
Dim i As Long
Dim x As Double
Dim s As String
With ActiveSheet
For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row Step 6
Set r = .Cells(i, 3).MergeArea
s = "D:\画像\" & .Cells(i, 2).Value & ".jpg"
If Dir(s) = "" Then
s = "D:\画像\noimage.jpg"
Else
Dir Application.Path
End If
'r.Item(1).Value = s
With .Pictures.Insert(s).ShapeRange
.LockAspectRatio = msoTrue
x = Application.Min(r.Width / .Width, (r.Height - n) / .Height)
.Width = .Width * x
.Left = r.Left
.Top = r.Top + n / 2
End With
Next
End With
Set r = Nothing
End Sub
こんな感じで n の数値を変更して調整してください。
必要であればWidthとLeftも同じように。
中央に配置したい場合は以下に変更。
.Left = r.Left + (r.Width - .Width) / 2
.Top = r.Top + (r.Height - .Height) / 2
end-uさん
おぉ!まさにこれを求めていました。ありがとうございます。
欲を言うと・・・。No Imageの画像には非対応な感じでしたので
No Image画像にも同様、枠内に収めたいのですが。マクロ文を追加
しないとダメでしょうか?それとももともとの画像サイズが大きいとか
ですかね??
No.3
- 回答日時:
>No Imageの画像には非対応な感じでしたので
>No Image画像にも同様、枠内に収めたいのですが。
...はて?解りません。
他のjpgファイルはokなのに『No Imageの画像』がNGなのですね。
ファイルの問題じゃないですか?
他のファイルで試したり、サイズ変更して作り直したりしてみれば良いんじゃないでしょうか。
後は、貴方の方で色々と工夫する事で対応できるのではないかと思います。
では、この辺で。がんばってください。
end-uさん
「No Image」の方の画像サイズを変更したら直りました。
ご指摘ありがとうございます。
これで理想としていたことが完成しました。本当にありがとうございました。
No.1
- 回答日時:
とりあえず、最低限の修正なら
Private Sub CommandButton1_Click()
Dim i As Long
Dim myPic As Object
Dim myCell As Range
For i = 2 To Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row Step 6
Set myCell = Range("B" & i)
Set myPic = ActiveSheet.Pictures.Insert("D:\画像\" & myCell.Value & ".JPG")
With myPic
.Left = Range("C" & i).Left
.Top = Range("C" & i).Top
.Width = Range("C" & i).MergeArea.Width
.Height = Range("C" & i).MergeArea.Height
End With
Set myPic = Nothing
Next i
End Sub
縦横比固定の場合
Sub try()
Dim r As Range
Dim i As Long
Dim x As Double
Dim s As String
With ActiveSheet
For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row Step 6
Set r = .Cells(i, 3).MergeArea
s = "D:\画像\" & .Cells(i, 2).Value & ".jpg"
If Dir(s) = "" Then
s = "D:\画像\noimage.jpg"
Else
Dir Application.Path
End If
'r.Item(1).Value = s
With .Pictures.Insert(s).ShapeRange
.LockAspectRatio = msoTrue
x = Application.Min(r.Width / .Width, r.Height / .Height)
If x < 1 Then .Width = .Width * x
.Left = r.Left
.Top = r.Top
End With
Next
End With
Set r = Nothing
End Sub
end-uさん
イメージ通りのものができました。ご回答ありがとうございます。
どこがどう反映されているか、なんとなく分かったような気がします。
ただ、C2に画像が入った場合に枠線の上に重なるように画像が貼り付けられてしまうので縦横比固定の箇所で倍率の変更が出きればと思うのですが・・・
そこだけ何か解決案があればお聞きしたいです。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
- Excel(エクセル) Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて 2 2022/11/15 16:14
- Excel(エクセル) エクセルで同じ数字同士を自動で線で結ぶVBAを教えてください 6 2022/04/26 23:13
- Visual Basic(VBA) エクセルマクロでアニメを作る方法を教えてください。 1 2023/02/07 14:27
- Visual Basic(VBA) 3つのプロシージャをまとめたら実行時エラー発生で対応不能 6 2022/05/17 01:47
- Excel(エクセル) 【マクロ】スクショ印刷がうまく動かない件 5 2022/12/06 17:37
- Excel(エクセル) excelで検索した商品の画像(ネットワーク上の)を表示させたい。 3 2023/06/28 00:32
- Visual Basic(VBA) Excle VBA Findメソッドについて 3 2022/07/15 13:56
このQ&Aを見た人はこんなQ&Aも見ています
-
外出時に「待たせる妻」vs イライラする「待つ夫」は日本だけ?見習いたい海外事情
夫の家事参加に積極的なイメージのある海外でも、同様の事例はあるのか。結婚カウンセラーの佐竹悦子さんに伺ってみた。
-
エクセル ハイパーリンクで画像を表示
その他(Microsoft Office)
-
エクセルで写真等を
Excel(エクセル)
-
VBAを使ったエクセルでの画像複数表示
Excel(エクセル)
-
-
4
【マクロ】でセルと同名の画像を表示させる
その他(Microsoft Office)
-
5
エクセル フォルダの画像を画像名で検索して貼り付け
Excel(エクセル)
-
6
エクセルのセルに指定画像(.jpg)を自動で貼り付けたいです。
Excel(エクセル)
-
7
エクセルに張り付けた写真のファイル名が見たい
Microsoft ASP
-
8
Excelで数字を入れたら対応する図を呼び出したい
Excel(エクセル)
-
9
Excel セルに入力した画像名からフォルダの画像を自動表示させたい
Excel(エクセル)
-
10
EXCEL ハイパーリンク先を表示させるには
Excel(エクセル)
-
11
エクセルのマクロでリンク先の画像を表示させたい
Excel(エクセル)
-
12
VBA フォルダ名と画像ファイル名取得
Visual Basic(VBA)
-
13
エクセル マクロ 相対パスから画像を読み込みたいです。
その他(Microsoft Office)
-
14
エクセルにハイパーリンクで貼り付けた画像を 通常の埋め込み画像に変換したいのですが、方法が分かる方が
Excel(エクセル)
-
15
エクセルで次々と画像を表示させたい
Excel(エクセル)
-
16
エクセル関数で画像を呼び出す方法ありますか?
Windows Vista・XP
-
17
条件に一致したときに画像を表示したいのですが・・。
Excel(エクセル)
-
18
エクセルのVBAでクリップボードにコピーした画像をpng(or jpg or bmp)保存したい
Visual Basic(VBA)
-
19
任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい
Visual Basic(VBA)
-
20
マクロでセルに入れたファイル名の画像を隣のセルに読み込みたい
その他(Microsoft Office)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
男の人はやってるとき 彼女がす...
-
彼と体の相性が良すぎて悩んで...
-
高校生です。彼氏の前で初めて...
-
夫婦の夜の営みについてです。 ...
-
女性が喘いでいるときの男性の...
-
抱きしめたときに勃起したあそ...
-
クンニしたことある人ー ま○こ...
-
彼氏と毎日セックスするのは異...
-
彼女が感じやすくて可愛い
-
もし週1しか恋人と会えなかった...
-
男性に質問です! 電話だけで勃...
-
男の人ってなんですぐ勃つの?...
-
兄妹や姉弟で、キスやエッチし...
-
男子高校生です。 彼女とエッチ...
-
SEXの相性が良すぎると男はダメ...
-
初体験って気持ちいいの? 男の...
-
彼氏のセックスが下手すぎで幻...
-
彼氏が勃っていました。 高校生...
-
ふぇらでイカセテくれる うまい...
-
風俗を利用した事がある男性の...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
男の人はやってるとき 彼女がす...
-
彼と体の相性が良すぎて悩んで...
-
高校生です。彼氏の前で初めて...
-
彼氏と毎日セックスするのは異...
-
女性が喘いでいるときの男性の...
-
抱きしめたときに勃起したあそ...
-
夫婦の夜の営みについてです。 ...
-
もし週1しか恋人と会えなかった...
-
彼女が感じやすくて可愛い
-
SEXの相性が良すぎると男はダメ...
-
兄妹や姉弟で、キスやエッチし...
-
男の人ってなんですぐ勃つの?...
-
彼女がフェラをしてくれません。
-
男子高校生です。 彼女とエッチ...
-
彼氏のセックスが下手すぎで幻...
-
クンニしたことある人ー ま○こ...
-
セックス中に動画や写真を撮る...
-
彼氏が勃っていました。 高校生...
-
初体験って気持ちいいの? 男の...
-
【男性に質問】彼女をぎゅっっ...
おすすめ情報