プロが教える店舗&オフィスのセキュリティ対策術

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

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

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

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

「マクロでセルに入れたファイル名の画像を隣」の質問画像

A 回答 (3件)

倍率の変更もですが、それより 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
    • good
    • 1
この回答へのお礼

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

お礼日時:2009/11/17 17:39

>No Imageの画像には非対応な感じでしたので


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

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

お礼日時:2009/11/18 09:18

とりあえず、最低限の修正なら


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
    • good
    • 1
この回答へのお礼

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

お礼日時:2009/11/17 14:49

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A