グッドデザイン賞を受賞したウォーターサーバー >>

例えば、Sheet1に、支店番号、支店名、住所、電話番号、地図(jpgファイル名)等の項目を作り、100件以上のレコードが入っている表があります。

Sheet2に、上記の1レコード(=1支店)分のデータをA4用紙に見やすく配置したフォーム(?)を作り、VLOOKUP関数を使って、データを表示させるようにしました。(つまりA支店の支店番号を選ぶとA支店のデータが、B支店の支店番号を選ぶとB支店のデータが表示)

★この時、それぞれのレコードのjpgファイルの画像も表示させたいのですが、どのようにすればできるのでしょうか?

ハイパーリンクのように他に飛んで表示させるのではなく、エクセルのその場所に表示させたいのです。(1支店分をA4用紙で印刷したいので)

別のシートで、実際に画像を貼付たものとその名前のデータベースを作り、それとリンクを貼る。という方法を知ったのですが、レコード件数がかなりあるので、この方法はちょっと使えません。

他に何かいい方法をご存知の方がいらっしゃいましたら、どうか教えて下さい!関数、Visual Basicの使用でも構いません。

ちなみに画像は、エクセルファイルの置いてある下(サブフォルダ)にまとめて入れております。宜しくお願い致します。

このQ&Aに関連する最新のQ&A

A 回答 (5件)

#1です。



ちなみにファイルのパスは例の通りでなくても大丈夫のハズです。
但し、
1)Excelファイルのあるフォルダのサブフォルダ名は「Image」
2)エラー時用のファイル名は「NoImage.jpg」
この2つを変える場合はコードの記載にある同様の部分を修正する必要があります。

 "\Image\" → "\好きなフォルダ名\"
 "\Image\NoImage.jpg" → "\好きなフォルダ名\好きなファイル名.jpg"

カスタマイズですが、

*支店コードを入れるセルを変えたい場合
 "$A$1" を好きなセルに変えます。
 但し、それによって地図ファイル名を表示させるセルは必ずその右隣のセルにします。

 例)"$A$1" → "$D$5" にした場合、"E5"に地図ファイル名をVLOOKUPで表示

*画像を表示する位置を変えたい場合
 全部で3箇所ある "$C$1" と "C1" を好きなセルに変えます。

*表示する画像のサイズを変えたい場合(今は横320x縦240です)
 .Range("C1").Left, .Range("C1").Top, 320, 240) の 320 と 240 を変更します。
    • good
    • 2
この回答へのお礼

わかりやすいご説明ありがとうございますっ!!!

場所を変えたり大きさ変えたり色々できました☆☆☆
変更したのがちゃんと反映されると嬉しい&楽しいですね♪

本当にどうもありがとうございました♪♪♪

お礼日時:2007/04/03 00:40

↓を見落としてました・・・。



>別のシートで、実際に画像を貼付たものとその名前のデータベースを作り、それとリンクを貼る。という方法を知ったのですが、レコード件数がかなりあるので、この方法はちょっと使えません。
    • good
    • 0
この回答へのお礼

おチカラになってくれようとして下さり、ありがとうございました。

お礼日時:2007/04/03 00:45

VBAを使用しない方法です。

面倒ですが・・・。

http://www.geocities.jp/chiquilin_site/data/0505 …
    • good
    • 2

#1です。



> 頭とおしりの『'-----』を付けたら。。。

先頭に『'』を付けるとコメント行の意味になり実行に影響を与えません。
従って『'-----』は特に関係無いのですが、、、、

ちなみに、上手く動くなら下記2箇所の先頭にある『'』は消した方が良いです。

'On Error GoTo ER:
  ・
  ・
'ER:

  ↓

On Error GoTo ER:
  ・
  ・
ER:
    • good
    • 2
この回答へのお礼

『'』は確かコメント行だから関係ないかな?とも思ったのですが、区切りとして必要だったから最初はエラーになってしまったのかな?と思ってしまいました。やはり関係なかったですね。。汗

『'On Error~』の件もありがとうございます。とってやってみます!

ありがとうございました。

お礼日時:2007/04/03 00:36

1)該当ブックの保存先のサブフォルダ名を Image とします。


2)Imageフォルダには地図ファイルの他に NoImage.jpg と言うエラー時のファイルを用意します。
3)Sheet2の A1 が支店コードを入力する欄とします。
4)Sheet2の B1 が支店コードによってVLOOKUPで地図ファイル名を表示するセルとします。
5)Sheet2のシート名を右クリックして「コードの表示」を押下し出てきたVBE画面に下記をコピペします。

'----------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape
'On Error GoTo ER:
 If Target.Address <> "$A$1" Then Exit Sub
 fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
 If Dir(fName) = "" Then
   fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
 End If
 With ActiveSheet
  For Each pict In .Shapes
   If pict.TopLeftCell.Address = "$C$1" Then
     pict.Delete
     Exit For
   End If
  Next pict
  Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
        .Range("C1").Left, .Range("C1").Top, 320, 240)
 End With
'ER:
End Sub
'----------------------------------------------------------------------

Excel保存フォルダ(例 C:\Test)
画像保存フォルダ(例 C:\Test\Image)
Sheet2の構成
  A1 支店コード(例 1001)
  B1 ファイル名(例 aaa.jpg)
のような感じです。

この回答への補足

早速の回答、ありがとうございます!!ですが、、やってみたのですが、、画像が表示されませんでした。(泣)(ドライブ、フォルダも例と同じにやってみても、、勿論NoImage.jpgも作りましたが)
Excel2002、Visual Basic 6.0ですが、バージョンの問題とかあるのでしょうか?また色々と変えたりしてやってみますが、もし何か注意点などあるようでしたら、教えて下さい。

補足日時:2007/03/31 02:28
    • good
    • 3
この回答へのお礼

きゃーー、出来ました☆出来ましたーー!!!
頭とおしりの『'-----』を付けたら。。。(汗。えっ?これだけの問題??)お騒がせしてすみませんでした。
なにわともあれ、papayukaさんのおかげで、やりたかった事が出来るようになりました☆本当にどうもありがとうございました!!!

お礼日時:2007/03/31 03:06

このQ&Aに関連する人気のQ&A

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

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

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qエクセル フォルダの画像を画像名で検索して貼り付け

商品リストを作っています。

エクセルシートのC列に商品名が入っています。(6桁の数字&アルファベット。たとえばA00123)
フォルダにその商品名をつけた画像がまとまっています。

B列に、その該当する画像を自動的に貼り付けたいのですがどうすればいいですか?
画像数は1000個くらいフォルダに入っています。毎週増えます。
エクセルに載せる数はそのうち半分くらいです。
画像がない場合もあるのでその場合は何かしらのエラーを表示させたいです。

マクロはド初心者です。切り貼りくらいしか出来ません。が、今勉強中です。

検索して下記の方法を見つけたのですが、未だ成功していません。

http://oshiete.goo.ne.jp/qa/2880877.html
こちらをALT+F11ででできた画面に張るまではよかったのですが、
実行しようとしても何も出てこず失敗しました。
(他のときは選択する名前が出てくるのですが。Subの後に入っている名前です。このリンクのだとsubがなくて名前がないため、マクロ実行できません)

http://oshiete.goo.ne.jp/qa/5890088.html
コピペして実行したのですが何もかわりませんでした。
ファイルがおいてある場所は "c:\あるフォルダ\"から "c:\picpic\"にかえました。
私のリストは商品名がB列にあるのですがそれが問題なのでしょうか。






excel2010
windows7
フォルダはマイドキュメントにあります。名前はpicpicです。



何か不足している情報がありましたら教えてください。
よろしくお願いいたします。

商品リストを作っています。

エクセルシートのC列に商品名が入っています。(6桁の数字&アルファベット。たとえばA00123)
フォルダにその商品名をつけた画像がまとまっています。

B列に、その該当する画像を自動的に貼り付けたいのですがどうすればいいですか?
画像数は1000個くらいフォルダに入っています。毎週増えます。
エクセルに載せる数はそのうち半分くらいです。
画像がない場合もあるのでその場合は何かしらのエラーを表示させたいです。

マクロはド初心者です。切り貼りくらいしか出来ません。が...続きを読む

Aベストアンサー

添付画像はこちらで実行した結果です。
hermosa90254さんが貼り付けておられたURLに書かれていたプログラムを一部修正したものです。
ExcelでVBE画面(Alt + F11)に下記プログラムをそのままコピペして実行してみてください。
ただし「写真の保存場所」で書かれているマイドキュメントのパスはご自身のパソコンのエクスプローラでご確認下さい。
(念のためVBE画面での操作手順画像を次の回答で添付します)

Sub macro1()
Dim p As String
Dim h As Range

'写真の保存場所
p = "C:\Users\☆☆☆\Documents\picpic\"

'現在表示されている写真は一度削除する
ActiveSheet.Pictures.Delete

'商品名が入力されている行まで繰り返す
For Each h In Range("D2:D" & Range("C1048576").End(xlUp).Row)

'写真ファイルが保存されている時
If Dir(p & h) <> "" Then
With ActiveSheet.Pictures.Insert(p & h)
.Name = h
'写真ファイル名が入力されているセルから2つ左のセルに挿入
.Top = h.Offset(0, -2).Top
.Left = h.Offset(0, -2).Left
'写真サイズの設定
.Width = h.Offset(0, 1).Width
.Height = h.Offset(0, 1).Height
End With
End If
Next
End Sub

添付画像はこちらで実行した結果です。
hermosa90254さんが貼り付けておられたURLに書かれていたプログラムを一部修正したものです。
ExcelでVBE画面(Alt + F11)に下記プログラムをそのままコピペして実行してみてください。
ただし「写真の保存場所」で書かれているマイドキュメントのパスはご自身のパソコンのエクスプローラでご確認下さい。
(念のためVBE画面での操作手順画像を次の回答で添付します)

Sub macro1()
Dim p As String
Dim h As Range

'写真の保存場所
p = "C:\Users\☆☆☆\Doc...続きを読む

QExcelで数字を入れたら対応する図を呼び出したい

いつもお世話になっております。
Excelで複数の地区の管理をしています。
地区には通し番号が付いていますおり、報告書を作るときにその通し番号入力します。
その時にスキャナで取り込んで通し番号を付けてある地図を入っているフォルダから自動的に呼んでくるようにはできないでしょうか?
わかりにくい文章ですみません。
よろしくお願いします。

Aベストアンサー

マクロになりますがいいですか?
このサンプルはA1セルにファイル名(拡張子なし)を入力したらD3セルに指定した画像を貼り付けるものです。

試しに新しいブックを開き「シート名右クリック」→「コードの表示」で開く画面に以下のマクロを貼り付けてください。マクロ2行目~5行目はご自身の環境に合わせて修正が必要です。

Private Sub Worksheet_Change(ByVal Target As Range)
Const trgR As String = "A1" '地図通し番号を入力するセル
Const insR As String = "D3" '挿入画像の左上のセル
Const path As String = "Z:\" 'ファイルの格納フォルダ
Const pic As String = ".jpg" '「.(半角)」+ファイルの拡張子"
Dim shp As Shape
Dim buf As String
  If Target.Address(0, 0) = trgR Then
    For Each shp In ActiveSheet.Shapes '既に表示されている画像を削除する処理
      If Not Intersect(Range(insR), Range(shp.TopLeftCell, _
            shp.BottomRightCell)) Is Nothing Then
        shp.Delete
      End If
    Next
    Range(insR).Select
    buf = Dir(path & Target.Value & pic)
    If buf <> "" Then '入力したファイル名があるかチェック
      ActiveSheet.Pictures.Insert (path & Target.Value & pic)
    Else
      MsgBox "指定したファイルがありません"
    End If
  End If
  Target.Offset(1, 0).Select
End Sub

これはあくまでサンプルですので、実際のシートにあわせてマクロを修正する必要があると思いますが、それはご自身でお願いします。

マクロになりますがいいですか?
このサンプルはA1セルにファイル名(拡張子なし)を入力したらD3セルに指定した画像を貼り付けるものです。

試しに新しいブックを開き「シート名右クリック」→「コードの表示」で開く画面に以下のマクロを貼り付けてください。マクロ2行目~5行目はご自身の環境に合わせて修正が必要です。

Private Sub Worksheet_Change(ByVal Target As Range)
Const trgR As String = "A1" '地図通し番号を入力するセル
Const insR As String = "D3" '挿入画像の左上のセル
Const p...続きを読む

Qエクセル ハイパーリンクで画像を表示

ハイパーリンクで画像を呼び出す際、クリックしてブラウザを立ち上げるのでなく、エクセルの画面上(セル内)にそのまま表示させる書式設定や関数などはありますか?ご存知でしたら教えて下さい。

<詳細>
画像入りの商品タグを自動で作成する表を作っています。
商品一覧表(シート(1))からタグを作りたいものにチェックを入れると、別シート(シート(2))にタグの体裁で情報が配置され、そのまま印刷できる…というものです(A4用紙1枚に縦型のタグが60枚程度)。
関数を使って文字情報を配置するところまでは何とかできたのですが、画像の配置のところでつまずいています。
取り急ぎ画像を直接ドラッグして配置し、1つ1つ並べ直していますが、商品数が多いのと(1万点ほど)情報の変更が頻繁にあるので、方法があれば画像も自動配置したいと思っています。

シート(1)
    A列     B列     C列(画像リンク)
1 商品番号 | 棚番A1 | C:\Dcuments (略) 001.jpg
2 商品番号 | 棚番A2 | C:\Dcuments (略) 002.jpg
3 商品番号 | 棚番B1 | C:\Dcuments (略) 003.jpg
   :

シート(2)
| ̄ ̄ ̄ ̄| ̄ ̄ ̄ ̄| ̄ ̄
|商品番号|商品番号|
|‥‥‥‥|‥‥‥‥|
|商品画像|商品画像|←※
|‥‥‥‥|‥‥‥‥|
|棚番:A1|棚番:A2|
|____|____|__
| ̄ ̄ ̄ ̄| ̄ ̄ ̄ ̄| ̄ ̄

※=HYPERLINK(シート(1)!C1,"■"))
(別名(■)のところをどうにかすればいいのでしょうか…)

どうぞよろしくお願いいたします。

ハイパーリンクで画像を呼び出す際、クリックしてブラウザを立ち上げるのでなく、エクセルの画面上(セル内)にそのまま表示させる書式設定や関数などはありますか?ご存知でしたら教えて下さい。

<詳細>
画像入りの商品タグを自動で作成する表を作っています。
商品一覧表(シート(1))からタグを作りたいものにチェックを入れると、別シート(シート(2))にタグの体裁で情報が配置され、そのまま印刷できる…というものです(A4用紙1枚に縦型のタグが60枚程度)。
関数を使って文字情報を配置するところ...続きを読む

Aベストアンサー

関数ですか...
無いこともなく、[名前の定義]と組み合わせれば可能ですが、
事前に画像を読み込んでおかないといけないので『(1万点ほど)』だとおよそ実用的ではないです。
一応、http://oshiete1.goo.ne.jp/qa5092871.html こちらで紹介したサイト
http://www.officetanaka.net/excel/function/tips/tips14.htm

http://www.geocities.jp/chiquilin_site/data/050530_search.html
ここなど参考になるかもしれません。

実際にはセルに画像ファイルのフルパスを入力しておいて、関数で参照し、
マクロで読み込むという処理になってしまうでしょうね。

以下Q&A参考に、セル位置等応用できれば、なんとかなるかもしれません。
『マクロでセルに入れたファイル名の画像を隣のセルに読み込む』
http://oshiete1.goo.ne.jp/qa5454724.html
『VBAを使ったエクセルでの画像複数表示』
http://oshiete1.goo.ne.jp/qa4004938.html
『社員写真帳への写真の取り込みについて質問です』
http://hpcgi1.nifty.com/kenzo30/b_cbbs/cbbs.cgi?mode=al2&namber=29522&rev=&no=0&P=R&KLOG=191

がんばってみてください。

関数ですか...
無いこともなく、[名前の定義]と組み合わせれば可能ですが、
事前に画像を読み込んでおかないといけないので『(1万点ほど)』だとおよそ実用的ではないです。
一応、http://oshiete1.goo.ne.jp/qa5092871.html こちらで紹介したサイト
http://www.officetanaka.net/excel/function/tips/tips14.htm

http://www.geocities.jp/chiquilin_site/data/050530_search.html
ここなど参考になるかもしれません。

実際にはセルに画像ファイルのフルパスを入力しておいて、関数で参照し、
マク...続きを読む

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

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

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

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

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

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

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

<内容>
セル内には上から1位・2位と順位通りになっており、その順位に入っているセルのファイル名と一致している画像を隣のセルに読み込みたいと思っています。またファイル名と画像が一致しない場合は「No Image」として1枚の画像を貼り付けることもしたいです。

   A(順位)  B(名)    C(画像)
...続きを読む

Aベストアンサー

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

倍率の変更もですが、それより 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
...続きを読む

Q任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるようにしようとすると、かなり難易度が高くお手上げ状態です。
このプログラムをどのように改修すれば可能になるかお教えください。

Sub 図11()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可)", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
Range("B6").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置:アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置:アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = ActiveCell.MergeArea.Height
End With

' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
ActiveCell.Offset(5).Select

Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True

End Sub

よろしくおねがいします。
※マクロはほぼ初心者です。大体がネットからコピペをして使っている程度のレベルです。

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるよう...続きを読む

Aベストアンサー

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトしてください。また、DoEvents も入れておきました。
④は、何も手を付けていません。
コメント・アウトした部分で不要なら削除してください。

'//
Sub 図11R()
 'No. 9024507
 Dim strFilter As String
 Dim Filenames() As Variant
 Dim fName As Variant, ext As String
 Dim PIC As Picture
 Dim k As Long, m As Long
 Dim i As Long, j As Long
 Dim cnt As Long
 Dim FirstRng As Range
 Dim r As Range
 Dim Sel_Folder As Object, Sel_Path As String
 cnt = 0 'カウントの初期値
 '貼り付け最初のセル
 Set FirstRng = Range("A2")
 
  Set Sel_Folder = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "フォルダを選択してください", 5)

  If Not Sel_Folder Is Nothing Then
    Sel_Path = Sel_Folder.Self.Path
  Else
   Exit Sub
  End If
 
 ' 「ファイルを開く」ダイアログでファイル名を取得
 ChDir Sel_Path
' strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
' Filenames = Application.GetOpenFilename( _
' FileFilter:=strFilter, _
' Title:="図の挿入(複数選択可)", _
' MultiSelect:=True)
 fName = Dir("*.*", vbNormal)
 Do While fName <> ""
  If fName <> "." And fName <> ".." Then
   ext = Mid(fName, InStrRev(fName, ".") + 1)
   If InStr(1, "jpg,jpeg,gif,bmp,png", ext, 1) > 0 And Not fName Like "#*" Then
    cnt = cnt + 1
    DoEvents
    ReDim Preserve Filenames(1 To cnt)
    Filenames(cnt) = fName
    ''安全のため(上限を設定)
    If cnt > 100 Then Exit Do
   End If
  End If
  fName = Dir()
 Loop
 If cnt = 0 Then Exit Sub
 
 ' ファイル名をソート
 Call BubbleSort_Str(Filenames, True, vbTextCompare)
 
 '' 貼り付け開始セルを選択
 'Range("B6").Select
 
 ' マクロ実行中の画面描写を停止
 Application.ScreenUpdating = False
 ' 順番に画像を挿入
 k = LBound(Filenames)
 m = UBound(Filenames)
 
 For j = 1 To Int(m / 4) + Abs(m Mod 4 > 0)
  For i = 1 To 4
   Set PIC = ActiveSheet.Pictures.Insert(Filenames(k))
   Set r = FirstRng.Cells(1 + (j - 1) * 2, i)
   
   '-------------------------------------------------------------
   ' 画像の各種プロパティ変更
   '-------------------------------------------------------------
   With PIC
    .Top = r.Top ' 位置:アクティブセルの上側に重ねる
    .Left = r.Left ' 位置:アクティブセルの左側に重ねる
    .Placement = xlMove ' 移動するがサイズ変更しない
    .PrintObject = True ' 印刷する
   End With
   With PIC.ShapeRange
    .LockAspectRatio = msoTrue ' 縦横比維持
    ' 画像の高さをアクティブセルにあわせる
    ' 結合セルの場合でも対応
    .Height = r.MergeArea.Height
   End With
   
   ' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
   ' ActiveCell.Offset(5).Select
   
   Set PIC = Nothing
   k = k + 1
   If k >= m Then Exit For
  Next i
 Next j
 Application.ScreenUpdating = True
 ChDir ThisWorkbook.Path
End Sub

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトし...続きを読む

Qエクセルで画像を自動的に挿入

エクセルは一般人程度の知識しかありません。
わたしは、デジカメの画像をエクセルに貼り付けて印刷しています。
(A4で、サイズ変更をして)
今までは、画像を貼り付けて、サイズ変更して、1画像ずつ配置していました。
しかし画像数が多いと配置の作業が大変です。画像を選択するだけでサイズ変更して自動的に配置してくれる機能なんてないですかね?
よろしくお願いします。

Aベストアンサー

検索すればそこかしこに情報があると思います。
我田引水ですが、
http://okwave.jp/qa3864319.html
更に、上記記事中のリンク先では、マクロの作り方も含めて説明してくれていますので、ご覧下さい。

Qexcelにて。VBAで、フォルダ内の画像を一覧の横に表示させたい。

excelにて。VBAで、フォルダ内の画像を一覧の横に表示させたい。

過去、似たような質問があり、ここに書かれているVBAを試したところ、やりたい事とかなり近かったです。
http://oshiete.goo.ne.jp/qa/2880877.html
しかしコレの場合、ある一つのセルへの入力に対して、一つの画像を表示する、といった形になっています。私がやりたいのは、さらに以下のようなことです。

1.あるシートのA列に、画像名の一覧がある。(マックス500行程度)
2.マクロを実行すると、A列と同名の画像が、あるフォルダから呼び出されてB列に表示される。
 (A2と同名の画像がB2へ、A3と同名の画像がB3へ、ということ)

※参照フォルダは固定でOKです。
※表示サイズはサムネイル程度の小さなものでOKです。前述リンク先のVBAのように、任意指定できれば尚可。


前述のリンク先にあるVBAを自分で書き換えられればよいのですが、どうすればセルを可変にできるのかわかりません。(それとも下方向に向けて反復するといった形に書き換えるんですかね??)

当方はVBAできません。ネットで拾ったものをコピペして使っているレベルです。
バージョンは2002です。よろしくお願いいたします。

excelにて。VBAで、フォルダ内の画像を一覧の横に表示させたい。

過去、似たような質問があり、ここに書かれているVBAを試したところ、やりたい事とかなり近かったです。
http://oshiete.goo.ne.jp/qa/2880877.html
しかしコレの場合、ある一つのセルへの入力に対して、一つの画像を表示する、といった形になっています。私がやりたいのは、さらに以下のようなことです。

1.あるシートのA列に、画像名の一覧がある。(マックス500行程度)
2.マクロを実行すると、A列と同名の画像が、あるフォルダから...続きを読む

Aベストアンサー

ご質問に書かれた
>あるシートのA列に、画像名の一覧がある。(マックス500行程度)

のようになっていない,たとえばA1やA2などのセルが空欄になっていて画像名が記入されていない状況が想定されます。


変更前:
if dir(p & h) <> "" then

変更後:
if h <> "" and dir(p & h) <> "" then

としてみます。



まだダメだったときは。
どんなデータも一つも通らずダメなのか,特定のセル番地,特定の画像名などでダメなのか,エラーの出る詳しい状況を何でも全て教えてください。
VBE画面でデバッグを行い,エラーが出た時点でhやらpにどんな内容が実際に入っていたのかを確認し,教えてください。
また念のためご利用のエクセルのバージョンについてもきちんと教えてください。



#基本ですがもしも「デバッグとは何ですか,どうしたらいいですか」について,やり方を知らない判らないときは必要に応じて別途ご相談を投稿してみてください。

QVBAで画像を表示する方法

VBA初心者です。ExcelのVBAでプログラミングの練習をしています。
早速ですが質問させてください。
ユーザーフォーム上にコマンドボタンをクリックすることにより画像を表示させることはできるのですが、これをユーザーフォームを開いた瞬間に自動的に表示させる方法はないのでしょうか?

ちなみに現在は以下のようにしています。
Private Sub CommandButton1_Click()
Image1.Picture = LoadPicture(" ")
End Sub

インターネットで調べてみても見つからないので質問させてもらいました。分かりにくい説明でしたらすみません。

Aベストアンサー

UserFormのinitializeイベントかActivateイベントを使ってください。

Private Sub UserForm_Initialize()
 Image1.Picture = LoadPicture("C:\aaa.jpg")
End Sub

または、

Private Sub UserForm_Activate()
 Image1.Picture = LoadPicture("c:\aaa.jpg")
End Sub

QExcel2010でセルに画像を呼び出す

Excel2010にシート1とシート2があります。
記入・印刷用シートはシート2とします。

シート1のA1セルに50pixel×50pixelの画像(png)を置きます。

シート2のA1セルに何か数字や文字が書かれた時に、
[マクロを使わずに]
シート2のB1セルに、シート1のA1セルにある画像を表示させるにはどうしたらいいですか?


上記ができない場合、シート2のB1セルにドロップダウンリストを作成して、
シート1のA1セルの画像を呼び出すことは可能ですか?

------------------------
Windows7 64bit
Excel2010 64bit
------------------------

Aベストアンサー

VLOOKUPで画像を変えたい
http://menushowdelay.blog13.fc2.com/blog-entry-518.html
の一番上のリンクなどはよく紹介されていますね。

QVBAを使ったエクセルでの画像複数表示

VBA初心者です。エクセルで商品カタログを作るため、品番に紐付いた商品画像ファイルをエクセル上に読み込む方法は他の回答から分かったのですが(http://oshiete1.goo.ne.jp/qa2880877.html)、見る限り「1シート=1商品」というものしか見つけられませんでした。同シート上に2つ以上の「品番⇒画像」という表示をするためのVBAはどのように組めばよろしいでしょうか?
VBAもよく勉強しないで恐縮ですが、どなたかご回答いただけますでしょうか?宜しくお願い致します。

Aベストアンサー

>現行の「A列入力⇒B列表示」の発展系で、「XXに入力⇒XXに表示」
>というように個別に指定することは可能なのでしょうか?
可能です。
>fn = .Cells(i, 1).Value
>Set r = .Cells(i, 2)
ここで使っているCellsプロパティは
Cells(行, 列)...で指定します。
この『列』である 1(A列) や 2(B列) を変更すれば良いです。
.Cells(i, "A").Value など文字列で指定する事もできます。

都度入力方式にしたいなら、変数を使って下記のようにします。
Sub try3()
  Dim r As Range '表示セル用
  Dim fd As String 'フォルダ用
  Dim fn As String '画像ファイル名用
  Dim x1 As String 'ファイル名列用
  Dim x2 As String '出力先列用
  Dim n As Long  '最下行用
  Dim i As Long  'Loopカウンタ
  
  With Application
    x1 = .InputBox("ファイル名の列入力" & vbLf & "ex) A", Type:=2)
    If x1 = "False" Then Exit Sub
    x2 = .InputBox("出力先の列入力" & vbLf & "ex) B", Type:=2)
    If x2 = "False" Then Exit Sub
  End With
  If Len(x1) = 0 Or Len(x2) = 0 Then Exit Sub
  fd = FDselect("画像フォルダ選択")
  If Len(fd) = 0 Then Exit Sub
  On Error GoTo errHndlr
  With ActiveSheet
    n = .Cells(.Rows.Count, x1).End(xlUp).Row
    If n = 1 And Len(.Cells(1, x1).Value) = 0 Then Exit Sub
    Application.ScreenUpdating = False
    For i = 1 To n
      fn = .Cells(i, x1).Value
      If Len(fn) > 0 Then
        Set r = .Cells(i, x2)
        If Len(Dir(fd & fn)) > 0 Then
          With .Pictures.Insert(fd & fn).ShapeRange
            .LockAspectRatio = msoTrue
            .Left = r.Left
            .Top = r.Top
            .Height = r.Height
          End With
        End If
      End If
    Next
  End With
errHndlr:
  Set r = Nothing
  Application.ScreenUpdating = True
  If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description
End Sub

'FolderSelectFunction
Private Function FDselect(ByVal s As String) As String
  Dim obj As Object
  Dim ret As String

  Set obj = CreateObject("Shell.Application") _
       .BrowseForFolder(0, s, 0)
  If obj Is Nothing Then Exit Function
  On Error Resume Next
  ret = obj.self.Path & "\"
  If Err.Number <> 0 Then
    ret = obj.Items.Item.Path & "\"
    Err.Clear
  End If
  On Error GoTo 0
  Set obj = Nothing
  FDselect = ret
End Function

ただ、最初に書いてますが
>>VBAもよく勉強しないで恐縮ですが、
>ではメンテナンスの時に困りますから、よく勉強してくださいね。

>現行の「A列入力⇒B列表示」の発展系で、「XXに入力⇒XXに表示」
>というように個別に指定することは可能なのでしょうか?
可能です。
>fn = .Cells(i, 1).Value
>Set r = .Cells(i, 2)
ここで使っているCellsプロパティは
Cells(行, 列)...で指定します。
この『列』である 1(A列) や 2(B列) を変更すれば良いです。
.Cells(i, "A").Value など文字列で指定する事もできます。

都度入力方式にしたいなら、変数を使って下記のようにします。
Sub try3()
  Dim r As Range '表示セル用
  Dim fd...続きを読む


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

人気Q&Aランキング