[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『画像ファイル複数読み込み、仕分け』（またむら）
初めまして。 この質問は以前、Office TANAKAの方でさせていただいたのですが回答も少なく解決せず、こちらで質問させて頂く事になりました。 http://officetanaka.com/patio/patio.cgi?mode=view&no=3766 過去ログを拝見しましたが、検索の仕方が悪いのかヒットせず、新規の投稿となります。
長くなりますが以下、質問内容。
１つのシートに何枚もの画像を挿入したいです。 画像は●と言うのが●-1、●-2と存在します。 ●は■だったり▲だったりします。 全部、-1と-2の画像があり、それを一括で挿入したいのです。 セルを選択して貼り付けるやり方だと、効率があまり良くないので、 マクロとかを使って少しでも楽に出来ないかな、と思った次第です。
様式は、タイトルと枠が２つあり、縦に10枚以上同じ形で作られています。 この枠の中に-1と-2をそれぞれ入れたいです。タイトルには●が入ってます。
フルパスを使えば出来るかも知れない、と言うのは自分で調べたりしてわかったつもりです。 しかし、マクロは記録で画像の縮小をやっと出来る程度。 あまり詳しくなく、コードも調べたりして自分なりに勉強はしていますが、やりたい事まで追いつきません。 出来る事ならコードを教えて頂けると嬉しいです。
初心者同然ですが、良ければ皆さんの力を貸してもらえませんか？
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
>フルパスを使えば出来るかも知れない、 というのはちょっとよくわかりませんが、
まずは > 様式は、タイトルと枠が２つあり、縦に10枚以上同じ形で作られています。 のセル位置を説明出るでしょうか。
>セルを選択して貼り付けるやり方だと、効率があまり良くないので、 とありますが、基本的にはループなりで指定したセル（選択ではない）に配置する 処理になると思います。
たとえば、Bの偶数行のセルに順番に貼り付けるなら、こんな感じで。下記は http://www.moug.net/tech/exvba/0120027.html を参考にしています。
For i=1 To 10
If Dir( "画像のあるパス\●-" & i & ".jpg") = "" Then Exit For
Set Target = Range("B" & i * 2)
With ActiveSheet.Pictures.Insert("画像のあるパス\●-" & i & ".jpg")
rX = Target.Width / .Width
rY = Target.Height / .Height
If rX > rY Then
.Height = .Height * rY
Else
.Width = .Width * rX
End If
.Left = Target.Left + (Target.Width - .Width) / 2
.Top = Target.Top + (Target.Height - .Height) / 2
End With
Next
サンプルコードは「VBA 画像 貼り付け」などで検索すると山のようにあるので、 自分にあったのを参考にするとよいかと思います。 （Mook） 2014/08/21(木) 18:11
Mookさん
早速の回答ありがとうございます。 説明不足、申し訳ないです。
>セル位置を説明出るでしょうか。 様式はB1～AA27までのセルを結合したりで組まれ、 B19～N27に-1、O19～AA27に-2を挿入するようになっています。 ↑は一行に変更可能ですが、一列にする事は不可能です…。以下理由。 セル上部、B1～AA18は、G2にタイトルがあり、他は業務上のデータが入力されます。 B28以下、同じように様式が作られています。
>>フルパスを使えば出来るかも知れない、 >というのはちょっとよくわかりませんが、 これは、色々なサイトや質問掲示板などを拝見した際、 フルパスを使って画像を取り込んでくる、と言う事が出来るのを知ったのです。 なので、フルパスを画像を挿入したいセルに読み込む事が出来たら、 自動的に画像を挿入出来るのではないか、と安易な発想に至りました。
提示して頂いたサンプル内の●は固定ですか？ もしそうであるなら、●以外の文字だと対応出来ないのでは…と思いました。 セル選択をするのは現状と変わらないので、それを回避出来たら、と思い質問しました。 （またむら） 2014/08/21(木) 18:43
セルの配置はどのようにもなるので、制限はありません。 １、２しか説明がありませんが、19行目に13列毎、13×9のセルに配置すればよいのですか？
>提示して頂いたサンプル内の●は固定ですか？ サンプルは固定ですが、 > ●は■だったり▲だったりします。 の●に変わるものはどのように指定したいのでしょうか。
Set Target = Range("B" & i * 2)
の部分を
Set Target = Range("B19").Offset((i-1)*13).Resize(13,9)
とすれば、 「B19～N27に-1、O19～AA27に-2を挿入する」ようにはなります。
ファイルの選択はダイアログ等で実現できると思いますが、 上記のファイルがあるフォルダは、処理のつど変更になるのですか？ （Mook） 2014/08/21(木) 19:09
Mookさん
>１、２しか説明がありませんが、19行目に13列毎、13×9のセルに配置すればよいのですか？ またの説明不足すみません…。 そういう事になります。 それがもう一つ横につくわけです。 そして、18行開いてまた同じの13×9が２つある形です。
>> ●は■だったり▲だったりします。 >の●に変わるものはどのように指定したいのでしょうか。 タイトル内に●が表記されているので、それを参照出来たら良いなと思います。 タイトルと画像の●はイコールなので。
>上記のファイルがあるフォルダは、処理のつど変更になるのですか？ 画像ファイル名を変える事があっても、フォルダ場所、名前は変わりません。
（またむら） 2014/08/21(木) 19:42
どうも不明な点が多いですけれど、 G2 にタイトル、B19-AA27 に画像が２つ、というパターン（位置関係）が2×Nで 続くと仮定した例です。
配置が異なる場合は、位置の指定を変更してください。
Sub Sample()
Const 画像フォルダ = "C:\Pics\"
Dim 行 As Long
For 行 = 19 To 100 Step 18
画像読込 画像フォルダ & Cells(行 - 17, "G").Value & "-1.jpg", Cells(行, "B").Resize(9, 13)
画像読込 画像フォルダ & Cells(行 - 17, "G").Value & "-2.jpg", Cells(行, "O").Resize(9, 13)
画像読込 画像フォルダ & Cells(行 - 17, "AG").Value & "-1.jpg", Cells(行, "AB").Resize(9, 13)
画像読込 画像フォルダ & Cells(行 - 17, "AG").Value & "-2.jpg", Cells(行, "AO").Resize(9, 13)
Next
End Sub
Sub 画像読込(画像パス As String, 張付けセル As Range)
If Dir(画像パス) = "" Then Exit Sub
Dim rX As Double
Dim rY As Double
With ActiveSheet.Pictures.Insert(画像パス)
rX = (張付けセル.Width - 2) / .Width
rY = (張付けセル.Height - 2) / .Height
If rX > rY Then
.Height = .Height * rY
Else
.Width = .Width * rX
End If
.Left = 張付けセル.Left + (張付けセル.Width - .Width) / 2 + 0.5
.Top = 張付けセル.Top + (張付けセル.Height - .Height) / 2 + 0.5
End With
End Sub
（Mook） 2014/08/21(木) 20:34
遅くなりました。 このコードの変更は()内を変えたら良いんですよね？
（またむら） 2014/08/22(金) 07:46
＞このコードの変更は()内を変えたら良いんですよね？ 何を変更するかによって、どこを変更するのか変わってくると思いますが。。。？
＞＞配置が異なる場合は、位置の指定を変更してください。 の事なのかな？
＞G2 にタイトル、B19-AA27 に画像が２つ、というパターン（位置関係）が2×Nで ＞続くと仮定した例です。 の様に、実際はどの様になっているのか書いてみられてはどうでしょう？ （HANA） 2014/08/23(土) 15:39
それと、元スレ http://officetanaka.com/patio/patio.cgi?mode=view&no=3766 にもコメントしていますが、 Pictures.Insertメソッドは 2010から「リンク貼り付け」に仕様が勝手に変更されました。 （Picturesは非表示オブジェクトなんだから、今さらそこまで変更する必要ないのに？）
ディスクの画像ファイルとリンクする形式だと、ファイルを配布するときに元の画像ファイルを 添付しないといけないのでとても煩雑です。 Shapes.AddPicture に切り替えたほうがよさげ とおもいますが。
（kanabun） 2014/08/23(土) 17:54
遅くなり申し訳ありません。
HANAさん 位置指定を配置する事です。 実際ですか…
A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA 1 ＿＿＿＿＿＿＿＿＿ 様式名 ＿＿＿＿＿＿(罫線で囲い有) 2 │タイトル │ ● │年月日 │ 何年何月何日│ 3 │ 場所 │ １２市 │会社名 │ 株式会社 │ 4 │ 種類１ │ 表 │数値１ │ 123456 │ 5 │ 種類２ │ 雑 │数値２ │ 789123 │ 6 │ 備考 │ なし │ 高さ │ 456m │ 7 │ │ . │ │ . │ │ . │ │ 18 │ 写真１ │ 写真２ │ 19 │ │ │ 20 │ │ │ 21 │ │ │ 22 │ ●-1挿入 │ ●-2挿入 │ 23 │ │ │ 24 │ │ │ 25 │ │ │ 26 │ │ │ 27 │ │ │ ├──────────────────────────┤ 28 │タイトル │ ■ │年月日 │ 何年何月何日│ 29 │ 場所 │ １２市 │会社名 │ 株式会社 │ 30 │ 種類１ │ 表 │数値１ │ 123456 │ 31 │ 種類２ │ 雑 │数値２ │ 789123 │ 32 │ 備考 │ なし │ 高さ │ 456m │ 33 │ │ . │ │ . │ │
こんな感じでしょうか？
kanabunさん
ファイルは配布せず、PDF化と印刷なので、 画像リンクの問題は気にしなくても良いと思います。 画像フォルダも移動等しないので…。 （またむら） 2014/08/25(月) 17:57
横から失礼します。 VBA学習中のものです。 きっと業務データのシートがあると仮定して作りました。 業務データシートのA列にタイトルがあるとしています。 画像リンクで構わないとのことですので、画像添付はMookさんの提案を使わせていただきました。
Sub ten() Dim i As Long, r As Long Dim Target As Range, hani As Range, c As Range Dim sh1 As Worksheet, ten As Worksheet Dim pFile As Variant
Set sh1 = ThisWorkbook.Sheets("データ") 'データのあるシート
Set ten = ThisWorkbook.Sheets("台帳") '写真を貼るシート
With sh1
Set hani = .Range("A2:A" & .Range("A1").End(xlDown).Row) 'データのある箇所
r = 21
ten.Activate
For Each c In hani
For i = 1 To 2
pFile = "C:\Users\なまえ\Desktop\test\" & c & "-" & i & ".JPG" '写真のあるPathと写真名
If i = 1 Then
Set Target = ten.Range("C" & r & ":M" & r + 4)
Call 画像貼付(Target, pFile)
Else
Set Target = ten.Range("P" & r & ":Z" & r + 4)
Call 画像貼付(Target, pFile)
End If
Next i
r = r + 26
Next c
End With
End Sub
Sub 画像貼付(Target As Range, pFile As Variant)
Dim rX As Double
Dim rY As Double
With ActiveSheet.Pictures.Insert(pFile)
rX = (Target.Width - 2) / .Width
rY = (Target.Height - 2) / .Height
If rX > rY Then
.Height = .Height * rY
Else
.Width = .Width * rX
End If
.Left = Target.Left + (Target.Width - .Width) / 2 + 0.5
.Top = Target.Top + (Target.Height - .Height) / 2 + 0.5
End With
Set Target = Nothing
End Sub
（ten） 2014/08/27(水) 17:13
おそくなりましたが、コードありがとうございます。
PicturesクラスのInsertプロパティを取得できません
と出ました…。
入力変更が間違っていたのでしょうか…
（またむら） 2014/08/28(木) 18:52
あと、エクセルは使い回しになるので 出来たらフォルダ箇所は随時変更出来るようにしたいのですが…
これは欲張りですかね…？ （またむら） 2014/08/28(木) 18:55
tenさん
出来ました！汗
ただ、マクロ内で写真が１枚しか選択できず、 位置は問題ないのですが全てのセルに 同じ写真が貼られてしまいます…
写真はタイトル内の文字を参照し、 それに合った、１と２を左と右に貼り付けたいです。 (詳しくは前文参照願います。)
よろしくお願いします。 （またむら） 2014/08/28(木) 19:00
＞ 出来たらフォルダ箇所は随時変更出来るようにしたいのですが…
ファイルPathを ThisWorkbook.Path にして、写真とエクセルを同じフォルダにいれてあげれば、可能です。
＞ただ、マクロ内で写真が１枚しか選択できず、 位置は問題ないのですが全てのセルに 同じ写真が貼られてしまいます…
テストしましたが、私のほうでは問題ないですけどね。。。 ところで、タイトルとなるセルを参照するのは、データというシートのA2セルから順にA3、A4・・・となりますが、良かったのですか？ もし問題ないのなら、写真名とタイトルが微妙に違うとか・・・ （ten） 2014/08/28(木) 22:42
書いたコードは、データのあるシートのA列（2行目以降から下）を参照して、データがある行まで順番に1,2とループしますので、同じ写真を貼ってしまうことはありえないような・・・。 それ以前に、エラー処理がないのでエラーがでてマクロがストップすると思います。 タイトルがAAAとすると、AAA-1,AAA-2という写真を読込みます。
データ用のシートがあるなら、それを参照したほうが良いかなぁと思っただけなので、画像貼付のシートに直接タイトルを入力しているのであれば、Mookさんからのご提案どおりだと思います。 話はそれますが、Mookさんのコードでまたひとつ勉強させていただきました。 （ten） 2014/08/29(金) 08:59
遅くなり申し訳ありません。
>ファイルPathを ThisWorkbook.Path にして、写真とエクセルを同じフォルダにいれてあげれば、可能です。 これは何処を変えたら良いのでしょうか…
ten.Activate
For Each c In hani
For i = 1 To 2
pFile = ThisWorkbook.Path & c & "_" & i & ".JPG" '写真のあるPathと写真名
If i = 1 Then
Set Target = ten.Range("C" & r & ":M" & r + 4)
Call 画像貼付(Target, pFile)
Else
こんな感じでしょうか？(抜粋)
>データ用のシートがあるなら、それを参照したほうが良いかなぁと思っただけなので、画像貼付のシートに直接タイトルを入力しているのであれば、Mookさんからのご提案どおりだと思います。 データシートはBOOK内に作成しています。
A＝タイトル B＝数値１ C＝数値２ ・ ・ ・
と言う感じで、 行ごとにデータが入力されています。
（またむら） 2014/09/04(木) 17:53
＞＞ファイルPathを ThisWorkbook.Path にして、写真とエクセルを同じフォルダにいれてあげれば、可能です。 ＞これは何処を変えたら良いのでしょうか…
pFile = ThisWorkbook.Path & "\" & c.Value & "_" & i & ".JPG" '写真のあるPathと写真名 で、大丈夫です。
あと、Mookさんが書いておられたように If Dir(pFile) = "" Then Exit For '写真が無かったら
処理速度を上げるように、 最初に Application.ScreenUpdating = False 最後に Application.ScreenUpdating = True も追加されたほうが良いですね。
それと、 Call 画像貼付(Target, pFile) が If文のなかに２つありますが、 外へ出して１つにしても･･･。 （End IfとNext iの間です）
タイトルから写真の枝番に繋がる文字はハイフンではなくてアンダーバーだったのですね(@_@) では、拙いコードで恐縮ですが、動いてくれれば幸いです。
（ten） 2014/09/05(金) 21:21
貼付に成功しました！ が、まだ提示して頂いた処理速度のコードと 写真がなかったらのコードは未入力です…苦笑
入れる場所があっていないのか、 エラーが出てしまうので後回しにしました。
それと、コードで一つ質問なのですが、 画像の大きさの指定は 画像貼付のコード内に含まれているのですよね？ 何処をいじれば大きさが変えられるのかわからないです…
貼り付けるセルが大きくて、余白がかなり…
教えて頂けるとありがたいです！ （またむら） 2014/09/08(月) 08:32
Set Target = ten.Range("C" & r & ":M" & r + 4)
↓
Set Target = ten.Range("C" & r).Resize(4, 10)
のように変更して、"C"および Resize(行,列)を、 様式にあわせて変更されたらどうでしょうか？
（ten） 2014/09/08(月) 13:31
わかりました！ と、やってみました！
今度は位置が合わないです… コードのそれぞれの意味？を理解していないと 思うように編集出来ず、中々大変ですね…痛感
With ActiveSheet.Pictures.Insert(pFile)
rX = (Target.Width - 2) / .Width
rY = (Target.Height - 2) / .Height
If rX > rY Then
・
・
・
辺りの数字を直せば良いのだろうか…とか思ってます←
見当違いならすみません。
（またむら） 2014/09/08(月) 17:37
リサイズで位置が動くのですね…！ （数字変えてて気付きました。）
けど、トップがやっぱり固定されているような…？ 気のせいなら申し訳ないです。 （またむら） 2014/09/08(月) 17:50
気のせいではないです。
トップは問題ないものだと思い込んでました。(^^;
位置を変えるには、ｒ＝21の数字を変えてください。
21行目から始まるという意味です。
End If
Next i
r = r + 26 ←この数字も次ページの画像位置に応じて変更が必要です。
Next c
End With
（ten） 2014/09/09(火) 09:09
おおっ！
教えて頂いた所を直しました！
完璧です！笑
長々とありがとうございました(^^)
あとはこれをショートカットとかに連動?させて 自分以外の人間にも使いやすくします！ （本当はボタン配置したかったけど、画像削除のマクロで消えてしまうので…苦）
また、何か困ったら質問したりしますが その時は気がついたらよろしくお願いします！ （またむら） 2014/09/09(火) 16:45
＞（本当はボタン配置したかったけど、画像削除のマクロで消えてしまうので…苦）
Sub 除去()
Dim pic As Object
For Each pic In ActiveSheet.Pictures
pic.Delete
Next
End Sub
試してみてください。 （ ten） 2014/09/10(水) 08:35
ボタンを配置しても消えない事に、密やかに感動しました(笑
tenさんには本当、何から何までお世話になりましたm(_ _)m （またむら） 2014/09/10(水) 09:17
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.