エクセル・マクロ・ソース

・複数の写真を均等に配置
  B2から1行おきに、高さ幅ともにアクティブセルに合わせる

Sub 複数の画像を挿入B2()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC       As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
                FileFilter:=strFilter, _
                Title:="図の挿入(複数選択可)", _
                MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
Range("B2").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
    Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

    '-------------------------------------------------------------
    ' 画像の各種プロパティ変更
    '-------------------------------------------------------------
    With PIC
        .Top = ActiveCell.Top        ' 位置:アクティブセルの上側に重ねる
        .Left = ActiveCell.Left    ' 位置:アクティブセルの左側に重ねる
        .Placement = xlMoveAndSize         ' 移動するがサイズ変更しない
        .PrintObject = True          ' 印刷する
    End With
    With PIC.ShapeRange
        .LockAspectRatio = msoFalse   ' 縦横比維持しない
        ' 画像の高さをアクティブセルにあわせる
        ' 結合セルの場合でも対応
        .Height = ActiveCell.MergeArea.Height
        .Width = ActiveCell.MergeArea.Width
    End With

    ' 次の貼り付け先を選択(アクティブセルにする)[例:2個下のセル]
    ActiveCell.Offset(2).Select

    Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True
MsgBox i & "枚の画像を挿入しました", vbInformation

End Sub


Private Sub BubbleSort_Str( _
ByRef Source As Variant, _
Optional ByVal SortAsc As Boolean = True, _
Optional ByVal Compare As VbCompareMethod = vbTextCompare)

If Not IsArray(Source) Then Exit Sub

Dim i As Long, j As Long
Dim vntTmp As Variant
For i = LBound(Source) To UBound(Source) - 1
    For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
        If StrComp(Source(IIf(SortAsc, j, j + 1)), _
                   Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
            vntTmp = Source(j)
            Source(j) = Source(j + 1)
            Source(j + 1) = vntTmp
        End If
    Next j
Next i

End Sub

・複数の写真を均等に配置
  D2から1行おきに、高さ幅ともにアクティブセルに合わせる

Sub 複数の画像を挿入D2()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC       As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
                FileFilter:=strFilter, _
                Title:="図の挿入(複数選択可)", _
                MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
Range("D2").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
    Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

    '-------------------------------------------------------------
    ' 画像の各種プロパティ変更
    '-------------------------------------------------------------
    With PIC
        .Top = ActiveCell.Top        ' 位置:アクティブセルの上側に重ねる
        .Left = ActiveCell.Left      ' 位置:アクティブセルの左側に重ねる
        .Placement = xlMove          ' 移動するがサイズ変更しない
        .PrintObject = True          ' 印刷する
    End With
    With PIC.ShapeRange
        .LockAspectRatio = msoFalse   ' 縦横比維持
        ' 画像の高さをアクティブセルにあわせる
        ' 結合セルの場合でも対応
        .Height = ActiveCell.MergeArea.Height
          .Width = ActiveCell.MergeArea.Width

    End With

    ' 次の貼り付け先を選択(アクティブセルにする)[例:2個下のセル]
    ActiveCell.Offset(2).Select

    Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True
MsgBox i & "枚の画像を挿入しました", vbInformation

End Sub


Private Sub BubbleSort_Str( _
ByRef Source As Variant, _
Optional ByVal SortAsc As Boolean = True, _
Optional ByVal Compare As VbCompareMethod = vbTextCompare)

If Not IsArray(Source) Then Exit Sub

Dim i As Long, j As Long
Dim vntTmp As Variant
For i = LBound(Source) To UBound(Source) - 1
    For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
        If StrComp(Source(IIf(SortAsc, j, j + 1)), _
                   Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
            vntTmp = Source(j)
            Source(j) = Source(j + 1)
            Source(j + 1) = vntTmp
        End If
    Next j
Next i

End Sub

msofalse

.Width= ActiveCell.MergeArea.Width