1シートに10枚の資料を作り画像を取り込む方法。

質問

現在、一つのシートに10枚づつ、資料が出来るようにコピーして使用しているのですが複数のセルに画像の取り込み方法をお知らせください。

画像を添付しようとしましたがうまく、出来ませんでした。

縦が71行で横が16列のファィルで画像を取り込むセルは、画像1は、D36で画像2は、I36で画像3はI54です、時々、画像4として、D54に入る場合があります。

2枚目は、画像1が、D107　画像2が、I107　画像3は、I125 画像4は、D125です。
3枚目は、画像1が、D178　画像2が、I178　画像3は、I196 画像4は、D196です。

10枚目は、画像1が、D675　画像2が、I675　画像3は、I693 画像4は、D693です。

うまく説明出来ず解かり辛いと思いますがよろしく、お願い致します。

よろしく、お願い致します。

回答No.3

keithin · ベストアンサー

そういった具合に（後出しで，というのも良くないですがそこはまぁちょっと脇に置いておくとしても）「あれもできたらいーな（クリックして実行したい），これもできたらいーな（１シートに１０枚作りたい）」と思いつきで機能を追加していくと，あとで「やっぱりこうしたい」と思ったり「今度はこーしてちょうだい」と新しいリクエストが降りてきても，ご自分ではすっかりワケ判らずで後戻りできなくなってしまいまた結局最初から誰かに作ってもらう羽目になりますよ？
また，ここのような質問相談掲示板は決してアナタの仕事をロハで下請けしてくれる，便利な無料の仕事屋じゃないってことを，勘違いしないようによく理解してください。

sub macro4()
　Dim myFiles As Variant
　Dim target As Variant, targete as range
　Dim i As Integer
　Dim s As String, ss As Variant
　dim p as long, startRow as long, pitchRow as long

'対象セルが変更になったら下記を書き換える
　target = Array("D36", "I36", "I54", "D54")
　startrow = 36
　pitchrow = 71

　if activecell.row < startrow then
　msgbox "Select correct area"
　exit sub
　end if
　p = int((activecell.row - startrow)/pitchrow)
　myFiles = Application.GetOpenFilename(filefilter:="画像(*.jpg),*.jpg", MultiSelect:=True)
　If Not IsArray(myFiles) Then Exit Sub

　On Error Resume Next
　for i = 0 to ubound(target)
　ActiveSheet.shapes("pict_" & range(target(i)).offset(p * pitchrow).address).Delete
　next i
　On Error GoTo 0

　For i = 0 To Application.Min(UBound(target), UBound(myFiles) - 1)
　　Set targete = Range(target(i)).Offset(p * pitchrow)
　　s = myFiles(i + 1)
　　With ActiveSheet.Pictures.Insert(s)
　　ss = Split(s, "\")
　　.name = "pict_" & targete.address
　　.Top = targete.Top
　　.Left = targete.Left
　　.Width = targete.MergeArea.Width
　　.Height = targete.MergeArea.Height
　　End With
　Next i

End Sub

作成したいセル（１枚分の中の任意のセルでよい）を選んでマクロを実行する。

お礼

keithin 様へ

何度も、何度も、質問を変更したのにもかかわらず、ご回答頂きまして、本当に助かりました。

10枚の様式ですが、現在、実際にコピーして使用していて、10枚すべてに画像が貼り付け出来たので、keithin様の細やかな対応して頂いた事を忘れ、身勝手なお願いばかりしまして、申し訳ありません。

お蔭様で、希望通りの動作をして画像貼り付けが簡単に出来るようになりました。
身勝手な質問に多大な時間等を費やされて、本当に、有難う御座いました。

回答No.2

keithin

間違い：
＞画像1は、D36で画像2は、I36で画像3はI54です、時々、画像4として、D54に入る場合があります。
＞2枚目は、画像1が、D107　画像2が、I107　画像3は、I125 画像4は、D125です。

全然間違い：
＞1枚目の画像貼り付けセルは、D36・I36・I54・D54です。

正解?
１枚目から４枚目（または３枚まで）の画像をD36, I36, I54, D54に
５枚目から８枚目（または７枚目まで）をそれぞれ７１行下のセルに

Sub macro3()
　Dim myFiles As Variant
　Dim target As Variant, targete as range
　Dim i As Integer, p As Integer
　Dim s As String, ss As Variant

'対象セルが変更になったら下記を書き換える
　target = Array("D36", "I36", "I54", "D54")

　for p = 0 to 9
　myFiles = Application.GetOpenFilename(filefilter:="画像(*.jpg),*.jpg", MultiSelect:=True)
　If Not IsArray(myFiles) Then Exit Sub
　On Error Resume Next
　ActiveSheet.Pictures.Delete
　On Error GoTo 0

　For i = 0 To Application.Min(UBound(target), UBound(myFiles) - 1)
　　set targete = range(target(i)).offset(p * 71)
　　s = myFiles(i + 1)
　　With ActiveSheet.Pictures.Insert(s)
　　ss = Split(s, "\")
　　.Name = ss(UBound(ss))
　　.Top = targete.Top
　　.Left = targete.Left
　　.Width = targete.MergeArea.Width
　　.Height = targete.MergeArea.Height
　　End With
　Next i
　next p

End Sub

補足

keithin 様へ

直ぐの対応に助かっております。
やはり私の説明が悪いみたいで申し訳ありません。
2回目の回答でほとんど、希望どおりですが下記の方法で画像の選択方法が出来ますと、10枚、別の調査結果の画像が選択出来るので記述致します。

D36をクリックした時に、D36 I36 D54 I54に貼り付ける画像が選べる。
D107をクリックした時に、D107 I107 D125 I125に貼り付ける画像が新たに選べる。
D178をクリックした時に、D178 I178 D196 I196に貼り付ける画像が新たに選べる。
D249をクリックした時に、D249 I249 D267 I267に貼り付ける画像が新たに選べる。
D320をクリックした時に、D320 I320 D338 I338に貼り付ける画像が新たに選べる。
D391をクリックした時に、D391 I391 D409 I409に貼り付ける画像が新たに選べる。
D462をクリックした時に、D462 I462 D480 I480に貼り付ける画像が新たに選べる。
D533をクリックした時に、D533 I533 D551 I551に貼り付ける画像が新たに選べる。
D604をクリックした時に、D604 I604 D622 I622に貼り付ける画像が新たに選べる。
D675をクリックした時に、D675 I675 D693 I693に貼り付ける画像が新たに選べる。

最初にD36をクリックした時に、D36 I36 D54 I54に貼り付ける画像が選べて、貼り付けが出来る。
上記で1つの動作(マクロ)が完了する。

次のD107をクリックした時に、D107 I107 D125 I125に貼り付ける画像が新たに選べて貼り付ける事が出来て、動作が完了すると、10枚、すべてに個々の違った画像を選択出来るので助かります。

旨く、説明が出来ず、申し訳ありません。

今回、希望の説明になっていると思います。

回答No.1

keithin

「同じものを」全部で１０セット作りたいということでしょうか。
であれば最初に作った４枚組を，あと９組コピーしてみます。

Sub macro1()
　Dim myFiles As Variant
　Dim target As Variant
　Dim i As Integer, p As Integer
　Dim s As String, ss As Variant

'対象セルが変更になったら下記を書き換える
　target = Array("D36", "I36", "I54", "D54")

　myFiles = Application.GetOpenFilename(filefilter:="画像(*.jpg),*.jpg", MultiSelect:=True)
　If Not IsArray(myFiles) Then Exit Sub
　On Error Resume Next
　ActiveSheet.Pictures.Delete
　On Error GoTo 0

　For i = 0 To Application.Min(UBound(target), UBound(myFiles) - 1)
　　s = myFiles(i + 1)
　　With ActiveSheet.Pictures.Insert(s)
　　ss = Split(s, "\")
　　.Name = ss(UBound(ss))
　　.Top = Range(target(i)).Top
　　.Left = Range(target(i)).Left
　　.Width = Range(target(i)).MergeArea.Width
　　.Height = Range(target(i)).MergeArea.Height
　　End With
　Next i

　For i = 0 To 3
’７１行ピッチが変わったら,下記を書き換える
　For p = Range(target(i)).Row + 71 To Range(target(i)).Row + 71 * 9 Step 71
　Range(target(i)).MergeArea.Copy Destination:=Cells(p, Range(target(i)).Column)
　Next p
　Next i

End Sub

補足

早速ためして見ましたら、同じ画像が10枚に出来ましたが。
1枚が1つの書類なので、1枚づつ、個々に別の4枚の画像を選んで貼り付けて1枚づつ、内容の違う画像を貼り付けた書類を作成したいのですが可能でしょうか。

1枚目の画像貼り付けセルは、D36・I36・I54・D54です。
2枚目は画像貼り付けセルは、D107・I107・I125・D125です。

71行で1枚の提出書類が出来ております。

説明が悪くて申し訳ありません。
よろしく、お願い致します。