[[20141014173109]]　『画像位置追加』（またむら）　ページの最後に飛ぶ

『画像位置追加』（またむら）

 お世話になってます。

 以前複数画像を一括貼付で質問させてもらい、
 解決しました。
[[20140821172908]]

 これに、また１つ画像を追加したいのですが、
 どうしたら良いのかわからず悩んでます(苦笑)

 今回は、過去ログの「写真１」「写真２」の上に
 もう一枚配置したいです。

 範囲はB8～AA16です。
 前回と違い、大きい画像となります。
 そして、同じように繰り返し貼り付けたい…。

 画像名は「要図1」「要図2」・・・「要図n」と言うことにします。

 是非皆様のお力をお貸しください…！

 因みに下が現在のマクロ。
 挿入するだけで済むならそれに越した事はないですよね…。

 Sub 遠近貼付()
Application.ScreenUpdating = False
  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("Sheet1")  '写真を貼るシート
  With sh1
    Set hani = .Range("A2:A" & .Range("A1").End(xlDown).Row)    'データのある箇所
   r = 20
  ten.Activate
    For Each c In hani
      For i = 1 To 2
           pFile = ThisWorkbook.Path & "\" & c.Value & "_" & i & ".JPG"    '写真のあるPathと写真名
           If Dir(pFile) = "" Then Exit For    '写真が無かったら
          If i = 1 Then
             Set Target = ten.Range("C" & r).Resize(8, 11)
             Call 画像貼付(Target, pFile)
          Else
             Set Target = ten.Range("P" & r).Resize(8, 11)
             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
    Application.ScreenUpdating = True
End Sub

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

回答がつかないようなので。
前スレはみていませんが、こんな感じでできると思います。
？？部分には適切な値を入れる必要があります。
コードの意味を理解する必要がありますが、
今後のためにもご自身で考えてみてください。

 r = 8
 --途中省略--
 For i = 1 To 3
     pFile = ThisWorkbook.Path & "\" & c.Value & "_" & i & ".JPG"    '写真のあるPathと写真名
     If Dir(pFile) = "" Then Exit For    '写真が無かったら
    If i = 1 Then
       Set Target = ten.Range("B" & r).Resize(??, ??)
    ElseIf i = 2 Then
       Set Target = ten.Range("C" & r + ??).Resize(8, 11)
    Else
       Set Target = ten.Range("P" & r + ??).Resize(8, 11)
    End If
    Call 画像貼付(Target, pFile)
  Next i
  r = r + ??

（マナ） 2014/10/15(水) 19:08

コメント返信：

[ 一覧(最新更新順) ]

[[20141014173109]] 『画像位置追加』（またむら） ページの最後に飛ぶ

[[20141014173109]]　『画像位置追加』（またむら）　ページの最後に飛ぶ