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

質問

• 1シートに10枚の資料を作り、複数のセルに画像を取り込む方法を教えてください。
• 現在、一つのシートに10枚づつ資料をコピーして使用していますが、画像を添付できません。
• 縦が71行で横が16列のファイルで、複数のセルに画像を取り込む方法を教えてください。

回答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様の細やかな対応して頂いた事を忘れ、身勝手なお願いばかりしまして、申し訳ありません。

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