そういった具合に(後出しで,というのも良くないですがそこはまぁちょっと脇に置いておくとしても)「あれもできたらいーな(クリックして実行したい),これもできたらいーな(1シートに10枚作りたい)」と思いつきで機能を追加していくと,あとで「やっぱりこうしたい」と思ったり「今度はこーしてちょうだい」と新しいリクエストが降りてきても,ご自分ではすっかりワケ判らずで後戻りできなくなってしまいまた結局最初から誰かに作ってもらう羽目になりますよ?
また,ここのような質問相談掲示板は決してアナタの仕事をロハで下請けしてくれる,便利な無料の仕事屋じゃないってことを,勘違いしないようによく理解してください。
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
作成したいセル(1枚分の中の任意のセルでよい)を選んでマクロを実行する。
間違い:
>画像1は、D36で画像2は、I36で画像3はI54です、時々、画像4として、D54に入る場合があります。
>2枚目は、画像1が、D107 画像2が、I107 画像3は、I125 画像4は、D125です。
全然間違い:
>1枚目の画像貼り付けセルは、D36・I36・I54・D54です。
正解?
1枚目から4枚目(または3枚まで)の画像をD36, I36, I54, D54に
5枚目から8枚目(または7枚目まで)をそれぞれ71行下のセルに
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
「同じものを」全部で10セット作りたいということでしょうか。
であれば最初に作った4枚組を,あと9組コピーしてみます。
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
’71行ピッチが変わったら,下記を書き換える
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
お礼
keithin 様へ 何度も、何度も、質問を変更したのにもかかわらず、ご回答頂きまして、本当に助かりました。 10枚の様式ですが、現在、実際にコピーして使用していて、10枚すべてに画像が貼り付け出来たので、keithin様の細やかな対応して頂いた事を忘れ、身勝手なお願いばかりしまして、申し訳ありません。 お蔭様で、希望通りの動作をして画像貼り付けが簡単に出来るようになりました。 身勝手な質問に多大な時間等を費やされて、本当に、有難う御座いました。