こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

マクロでセルに入れたファイル名の画像を隣のセルに読み込む

こんにちは。宜しくお願いします。

マクロで「セルに入れたファイル名の画像を隣のセルに読み込む」作業を行いたいのですが・・・。うまくいきません。どなたかご助言いただけると助かります。

<内容>
セル内には上から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

色々とネット等を見てはいるのですが・・・うまくいきませんでした。
どこをどのようにして代えればうまく動作するか分かる方いらっしゃいましたら教えていただきたいです。宜しくお願い致します。

大変申し訳ございませんが、この投稿に添付された画像や動画などは、「BIGLOBEなんでも相談室」ではご覧いただくことができません。 OKWAVEよりご覧ください。

マルチメディア機能とは?

投稿日時 - 2009-11-17 11:43:04

QNo.5454724

すぐに回答ほしいです

質問者が選んだベストアンサー

倍率の変更もですが、それより 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

投稿日時 - 2009-11-17 16:35:55

お礼

end-uさん
おぉ!まさにこれを求めていました。ありがとうございます。
欲を言うと・・・。No Imageの画像には非対応な感じでしたので
No Image画像にも同様、枠内に収めたいのですが。マクロ文を追加
しないとダメでしょうか?それとももともとの画像サイズが大きいとか
ですかね??

投稿日時 - 2009-11-17 17:39:07

ANo.2

このQ&Aは役に立ちましたか?

3人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.3

>No Imageの画像には非対応な感じでしたので
>No Image画像にも同様、枠内に収めたいのですが。
...はて?解りません。
他のjpgファイルはokなのに『No Imageの画像』がNGなのですね。
ファイルの問題じゃないですか?
他のファイルで試したり、サイズ変更して作り直したりしてみれば良いんじゃないでしょうか。
後は、貴方の方で色々と工夫する事で対応できるのではないかと思います。
では、この辺で。がんばってください。

投稿日時 - 2009-11-17 19:36:29

お礼

end-uさん
「No Image」の方の画像サイズを変更したら直りました。
ご指摘ありがとうございます。
これで理想としていたことが完成しました。本当にありがとうございました。

投稿日時 - 2009-11-18 09:18:52

ANo.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

投稿日時 - 2009-11-17 13:29:07

お礼

end-uさん
イメージ通りのものができました。ご回答ありがとうございます。
どこがどう反映されているか、なんとなく分かったような気がします。
ただ、C2に画像が入った場合に枠線の上に重なるように画像が貼り付けられてしまうので縦横比固定の箇所で倍率の変更が出きればと思うのですが・・・
そこだけ何か解決案があればお聞きしたいです。

投稿日時 - 2009-11-17 14:49:07

あなたにオススメの質問