【復活求む!】惜しくも解散してしまったバンド|J-ROCK編 >>

マクロを使って、フォルダ内の画像をエクセルに自動的に貼り付けできるようになりました。

http://oshiete.goo.ne.jp/qa/8357181.html
(picopico_7さんありがとうございました。)

しかし、出来上がったファイルをメールで他の人に送ると、その人のところではエラーがでて画像が見られません。「リンクされたイメージを表示できません」となります。

ネットで調べたところ、excel2010はリンクをつかって画像を表示するから?ということがわかりました。が、対処方法がわかりません。

どなたか教えて頂けませんでしょうか。
よろしくお願いいたします。


windows7
excel2010

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

A 回答 (4件)

#2です。


#3さんご指摘の通り、Shapes.AddPictureと、Pictures.Insertでは幅の挙動が異なりますね。
サイズとプロパティで確認すると、Pictures.Insertの方は縦横比の固定にチェックが入っています。
また、h.Offset(0, 1).Widthへの合致という点ではShapes.AddPictureの方が合っています。
With ActiveSheet.Pictures.Insert(OpenFileName)
.Name = h
.ShapeRange.LockAspectRatio = False
(以下略)
と、明示的に縦横比固定を外してやると、双方の挙動は同じになりました。
少なくともxl2010では、.Pictures.Insertはデフォルトでは縦横比固定になる様です。逆に言うと、元のままでは
'写真サイズの設定
.Width = h.Offset(0, 1).Width
.Height = h.Offset(0, 1).Height
は、後から行った方しか有効で無いという事でしょう。
ご参考まで。
    • good
    • 3

こんにちは。


画像の表示までは上手くいかれたみたいで良かったです。
#1,2のmitarashiさんが書かれている通りAddpictureを使われると効率的かと思い私の方でも試してみました。
が、写真サイズの設定だけがなぜだか上手くいきませんでした(私の知識不足です)。
なので今使われているプログラムに入れた状態で記しておきます。
コピペして写真の保存場所を直してから動かしてみてください。
(ちなみに追加した部分は「'リンク貼付画像を切り取る」「'写真ファイル名が入力されているセルから2つ左のセルを選択」「'画像をExcelシート自体に貼付」のみです)

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)
'写真ファイル名が入力されているセルから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
'リンク貼付画像を切り取る
.Cut
End With
'写真ファイル名が入力されているセルから2つ左のセルを選択
h.Offset(0, -2).Activate
'画像をExcelシート自体に貼付
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
End If
Next
End Sub
    • good
    • 6

#1です。


ご提示のコードに組み込むのは検証が面倒なので、下記コードでテストしました。ここからの載せ替えはご自分でお願いします。
Sub test()
Dim OpenFileName As String
Dim h As Range

'試験用に適当に指定
Set h = ActiveSheet.Range("D5")
OpenFileName = Application.GetOpenFilename("すべてのファイル,*.*")
If OpenFileName = "False" Then Exit Sub

'AddPictureを使用する時
'LinkToFile:=Falseだけでは不十分で、 SaveWithDocument:=Trueも必要な様です
ActiveSheet.Shapes.AddPicture(Filename:=OpenFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=h.Offset(0, -2).Left, _
Top:=h.Offset(0, -2).Top, _
Width:=h.Offset(0, 1).Width, _
Height:=h.Offset(0, 1).Height).Select
Selection.Name = h.Value

'既存のPictures.Insertを生かして、クリップボード経由でJPEG形式で貼り付ける時
' With ActiveSheet.Pictures.Insert(OpenFileName)
' .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
' .Cut
' End With
' h.Offset(0, -2).Activate
' ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
End Sub
    • good
    • 4

下記が詳しいです。


http://www.moug.net/tech/exvba/0120020.html

>Pictures.Insertメソッドを使った方法では、画像のリンク情報だけを保存する、または画像と一緒に保存するといった指定はできません。
>さらに、Excel 2007までは画像情報と一緒に保存されていたのに対し、Excel 2010でリンク貼り付けに仕様が変わるなど、Excelのバージョンによって画像の保存方法が異なります。

という訳で、Addpictureを使用して、明示的にLinkToFile:=Falseを指定して下さい。
ActiveSheet.Shapes.AddPicture( _
Filename:=myFileName, _
LinkToFile:=False, _
SaveWithDocument:=False, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=0, _
Height:=0)

参考URLにPictures.Insertメソッドを使い、クリップボードにコピーして貼り付け戻す対処方法も載っていますが、ファイルが巨大化する怖れがあります。単にペーストでなく、JPEG形式を指定して貼り付けるべきでしょう。

この回答への補足

mitarashiさん

回答ありがとうございます!
せっかくコードを貼り付けて頂いたのですが、どこにそれを入れて何を消したらいいのかわかりません。。
マクロ使い始めて1週間で何もわからなくて本当に申し訳ないのですが全体のコードをもらえませんでしょうか?
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

上記が今使わせてもらっているコードです。
いろいろ削除したり貼り付けしてみたのですがうまくいきませんでした。

リンク先のクリップボードにコピーというのもどうしていいかわからず、
>JPEG形式を指定して貼り付けるべきでしょう。
もわからないです。。
せっかく教えて頂いたのにすみません。ご回答いただけると有難いです。よろしくお願いいたします。

補足日時:2013/12/01 01:21
    • good
    • 1

この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...続きを読む

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【EXCEL】保存する時にリンク貼り付けを解除したい

販売管理からエクスポートしたエクセルデータを、エクセルで作った「報告書」にリンク貼り付けをしました。

データが更新された後、報告書の名前を、「○月報告書」というように別名で保存したいのですが、そのとき同時にリンク貼り付けを解除したいのです。

簡単にできるほう方法はないでしょうか?マクロなど。。。

是非教えてください!!!

Aベストアンサー

Excel2002以降なら「編集」「リンクの設定」の「リンクの解除」で選択したブックに対するリンク式を値化できます。

Qマクロで画像挿入→エラー「リンクされたイメージを表示できません」

マクロを使って、フォルダ内の画像をエクセルに自動的に貼り付けできるようになりました。
しかし、出来上がったファイルをメールで他の人に送ると、その人のところではエラーがでて画像が見られません。「リンクされたイメージを表示できません」となります。
ネットで調べてみましたが、画像の挿入のPictuers.insertをAddpictureに変えることが載っていたのですが、初心者ゆえよくわかりません。
どなたか教えて頂けませんでしょうか。
仕事で使うため、切羽詰っています。
どうか宜しくお願いいたします。

WINDOWS7
EXCEL2013を使っています。

'一括挿入(画像)

WS01.Select
Cells(9, 2).Select
For i = 2 To LastRow
'偶数の場合、次の処理を行う
If i Mod 2 = 0 Then
FName = WS02.Cells(i, 7)
Set Pict = WS01.Pictures.Insert(FName)
With Pict
.TopLeftCell = ActiveCell
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = ActiveCell.Height * 10.8
.Name = i - 1
End With
ActiveCell.Offset(13, 0).Activate
Set Pict = Nothing
End If
Next i

Cells(9, 10).Select
For i = 2 To LastRow
'奇数の場合、次の処理を行う
If i Mod 2 <> 0 Then
FName = WS02.Cells(i, 7)
Set Pict = WS01.Pictures.Insert(FName)
With Pict
.TopLeftCell = ActiveCell
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = ActiveCell.Height * 10.8
.Name = i - 1
End With
ActiveCell.Offset(13, 0).Activate
Set Pict = Nothing
End If
Next i
Cells(1, 1).Select

End Sub

マクロを使って、フォルダ内の画像をエクセルに自動的に貼り付けできるようになりました。
しかし、出来上がったファイルをメールで他の人に送ると、その人のところではエラーがでて画像が見られません。「リンクされたイメージを表示できません」となります。
ネットで調べてみましたが、画像の挿入のPictuers.insertをAddpictureに変えることが載っていたのですが、初心者ゆえよくわかりません。
どなたか教えて頂けませんでしょうか。
仕事で使うため、切羽詰っています。
どうか宜しくお願いいたします。...続きを読む

Aベストアンサー

急ぎなら特にマクロ全部を載せて下さい。
WS01やLastRowの定義が不明で苦労します。

前半で修正部分を書きました。後半も同様にしてみて下さい。、」

Dim Pict As Shape
WS01.Select
Cells(9, 2).Select
For i = 2 To LastRow
'偶数の場合、次の処理を行う
If i Mod 2 = 0 Then
fname = WS02.Cells(i, 7)
With ActiveCell
Set Pict = WS01.Shapes.AddPicture(fname, False, True, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height * 10.8)
End With
With Pict
.Name = i - 1
End With

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

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

Aベストアンサー

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

Q複数の画像ファイルを挿入したい

工事の仕事をしています。
報告書をエクセルで書いて出すのですが、
現場の写真を大量に撮影して貼り付けなければなりません。

「挿入」→「ファイルから」で一枚一枚貼り付けているのですが手間でなりません。

デジカメで撮影した写真なのでファイル名は連番です。
一括でワークシートにズラッと並べて挿入することはできないのでしょうか?

週末1-200枚の写真を貼る為に残業するのは堪えます。
良い知恵をお貸し下さい。

Aベストアンサー

工事写真票の作成ですか?報告書の提出時期ですものね。(^^;)

工事写真ということで、次の点が重要になるかと思います。

1. 貼付けられる順番
  工事の様子を時間を追って撮影している場合、順番が重要です。
2. リサイズの問題
  工事写真は正確性が求められます。リサイズする場合、縦横比を固定すべきです。

1と2をクリアしつつ、貼付けを楽にするには、EXCELではマクロしか解決方法がありません。個人的にはVIXをお勧めしますが、一応EXCELでのマクロをアップします。貼付け後のサイズはセルの高さにあわせています。必要があれば、コードをカスタマイズして下さい。

ただ、他の方からもご指摘があるとおり、EXCELに200枚の画像は無茶ですね。複数のブックに切り分けましょう。

なお、マクロ[InsertPictures]は#2.papayukaさんのコードをかなり拝借しておりますし、配列のソートプログラムも以前どこかで教えて頂いたものです。クイックソートの方が早いのですが、長くなるので、バブルソートで済ませています。


以下コード。

Option Explicit
Sub InsertPictures()
  
  Dim fName As Variant
  Dim i As Long
  Dim Pict As Picture

  fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True)
  If IsArray(fName) Then
    Application.ScreenUpdating = False
    '配列に格納されたファイル名をソート
    BubbleSort fName, True
    For i = 1 To UBound(fName)
      Set Pict = ActiveSheet.Pictures.Insert(fName(i))
      With Pict
        .TopLeftCell = ActiveCell
        .ShapeRange.LockAspectRatio = msoTrue
        'どちらかをコメントアウト
        .ShapeRange.Height = ActiveCell.Height 'セルの高さリサイズ
        '.ShapeRange.Width = ActiveCell.Width 'セルの幅にリサイズ
        ActiveCell.Offset(0, 1) = fName(i) 'ファイル名書込み
      End With
      ActiveCell.Offset(2, 0).Activate
      Application.StatusBar = "処理中:" & i & "/" & UBound(fName) & "枚目"
    Next i
  End If
  With Application
    .StatusBar = False
    .ScreenUpdating = True
  End With
  Set Pict = Nothing
  MsgBox i & "枚の画像を挿入しました", vbInformation

End Sub

'値の入替え
Public Sub Swap(ByRef Dat1 As Variant, ByRef Dat2 As Variant)

  Dim varBuf As Variant
  varBuf = Dat1
  Dat1 = Dat2
  Dat2 = varBuf

End Sub

'配列のバブルソート
Public Sub BubbleSort(ByRef aryDat As Variant, _
  Optional ByVal SortAsc As Boolean = True)

  Dim i As Long
  Dim j As Long
  For i = LBound(aryDat) To UBound(aryDat) - 1
    For j = LBound(aryDat) To LBound(aryDat) + UBound(aryDat) - i - 1
      If aryDat(IIf(SortAsc, j, j + 1)) > aryDat(IIf(SortAsc, j + 1, j)) Then
        Call Swap(aryDat(j), aryDat(j + 1))
      End If
    Next j
  Next i

End Sub

工事写真票の作成ですか?報告書の提出時期ですものね。(^^;)

工事写真ということで、次の点が重要になるかと思います。

1. 貼付けられる順番
  工事の様子を時間を追って撮影している場合、順番が重要です。
2. リサイズの問題
  工事写真は正確性が求められます。リサイズする場合、縦横比を固定すべきです。

1と2をクリアしつつ、貼付けを楽にするには、EXCELではマクロしか解決方法がありません。個人的にはVIXをお勧めしますが、一応EXCELでのマクロをアップします。貼付け後のサイズはセ...続きを読む

QVBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)

エクセル貼り付けた画像をセルにあった大きさにしたいのですが、
その際、縦と横の比率を変更したくありません。

縦と横の比率を変更せず、セルにおさまる最大の大きさで画像のサイズを
変えることは可能でしょうか。

-----------------------------------------------------------------------------
縦と横の比率が関係なく、セルいっぱいのサイズに画像の大きさを変更するVBAは
下記URLから見つけられたのですが、、、、、
http://q.hatena.ne.jp/1240648036

Aベストアンサー

No.1です。

>画像が置いてあるセル上で処理を行う

画像のどこを基準にするか?によってコードは変わってきますが、
画像の左上端のセルにその画像を縦・もしくは横いっぱいに配置するコードにしてみました。

Sub Sample2()
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

For Each mySp In ActiveSheet.Shapes
With mySp
Set myRng = .TopLeftCell
myHgt = myRng.Height
myWdt = myRng.Width
.Top = myRng.Top
.Left = myRng.Left
.Height = myHgt
If .Width > myWdt Then
.Width = myWdt
End If
End With
Next mySp
End Sub

こんな感じではどうでしょうか?m(_ _)m

No.1です。

>画像が置いてあるセル上で処理を行う

画像のどこを基準にするか?によってコードは変わってきますが、
画像の左上端のセルにその画像を縦・もしくは横いっぱいに配置するコードにしてみました。

Sub Sample2()
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

For Each mySp In ActiveSheet.Shapes
With mySp
Set myRng = .TopLeftCell
myHgt = myRng.Height
myWdt = myRng.Width
.Top = myRn...続きを読む

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)マクロ
 挿入-図-ファイル-図の挿入-図の書式設定-サイズ-30%

この作業を覚えさせると以下になりました。

Sub Macro3()
ActiveSheet.Pictures.Insert("C:\Documents and Settings\デスクトップ\1.JPG") _
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 360#
Selection.ShapeRange.Width = 480#
Selection.ShapeRange.Rotation = 0#
End Sub

これだと、写真が指定されてしまいます。
マクロの途中で止まって任意の写真を都度選べるようにできますか?
膨大な量の写真をセルに並べていきたいのです。

エクセルに画像を貼付け縮小する作業をマクロにしたいのですが、
分からない部分があって困ってます。

(1)挿入したいセルにカーソルを合わせる
(2)マクロ
 挿入-図-ファイル-図の挿入-図の書式設定-サイズ-30%

この作業を覚えさせると以下になりました。

Sub Macro3()
ActiveSheet.Pictures.Insert("C:\Documents and Settings\デスクトップ\1.JPG") _
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 360#
Selection.ShapeRange.Width =...続きを読む

Aベストアンサー

私も画像の取り込みでマクロをいじった経験があります。
こういうのはどうでしょう?(今動作確認できないのですが…)

Sub test()
ActiveSheet.Pictures.Insert(Application.GetOpenFilename).Select
Selection.Height = Selection.Height * 0.3
Selection.Width = Selection.Width * 0.3
End Sub

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&Aを見た人がよく見るQ&A

人気Q&Aランキング