EXCEL-VBA-セルに書いた画像ファイルをセルに配置する。

目的

動画コンテや図集の作成等、大量の画像ファイルをエクセルシートに配置したい。
手作業だと、画像を一か所に集めておくとまとめて取り込むことはできても、配置をいちいち変える必要がある。
一か所に集めるのも面倒な時もある。

方法

ファイル名がある程度規則的になっていると、ワークシート関数で、ファイル名を生成するのは容易。
選択範囲の中で、ファイル名らしきもの「[a-z]:\*」というパターンであれば、ファイル名と認識して、そのセルに取り込むマクロを作成した。ファイル名は、後で消すか、白い文字にして隠すことができる。

コード

Sub locate_images() 'セルに書いたパスの画像イメージを張り付ける
  For Each cl In Selection
    ctxt = cl.Value
    If Mid(ctxt, 2, 2) = ":\" Then 'File
      If Dir(ctxt) = "" Then
      Else
      ActiveSheet.Shapes.AddPicture(FileName:=ctxt, LinkToFile:=False, SaveWithDocument:=True, _
         Left:=cl.Left, Top:=cl.Top, Width:=50#, Height:=50).Select
      End If
    End If
  Next
End Sub

さらに、画像の一括設定

上では、画像の大きさを、仮に50*50で張り付けているが、一定のサイズで再配置したい。
その場合、1個だけ手で調整し、他の画像の設定はそれに合わせて統一するとよい。

Sub image_setting_unite()

  With Selection
    Set srng = Range(.TopLeftCell, .BottomRightCell)
     adrs = srng.Address(False, False)
     rs_lf = .Left -  Range(adrs).Left
     rs_tp = .Top - Range(adrs).Top
     s_wd = .Width
     s_ht = .Height
  End With
  ishp = 0
  For Each shp In ActiveSheet.Shapes
    ishp = ishp + 1
    Set s_rng = Range(shp.TopLeftCell, shp.BottomRightCell)
    s_adrs = s_rng.Address(False, False)
    shp.Left = Range(s_adrs).Left + rs_lf
    shp.Top = Range(s_adrs).Top + rs_tp
    shp.Width = s_wd
    shp.Height = s_ht
  Next
End Sub

画像トリミングの一括設定

Sub image_trim_all()
'選択した画像のトリミング設定を、シート内の全ての画像に適用する。
   With Selection
    a1 = .ShapeRange.PictureFormat.CropLeft
    a2 = .ShapeRange.PictureFormat.CropRight
    a3 = .ShapeRange.PictureFormat.CropTop
    a4 = .ShapeRange.PictureFormat.CropBottom
    name0 = Selection.Name
   End With
    
   For Each ashp In ActiveSheet.Shapes
    If (ashp.Name <> name0) Then
    ashp.Select
    With Selection
    .ShapeRange.PictureFormat.CropLeft = a1
    .ShapeRange.PictureFormat.CropRight = a2
    .ShapeRange.PictureFormat.CropTop = a3
    .ShapeRange.PictureFormat.CropBottom = a4
    End With
    End If
   Next
End Sub