画像をセルの大きさに合わせて連続挿入する (元の縦横比率は保持)

最終更新: 3月23日


ワークシート上に画像を連続して挿入するマクロです。セルの幅や高さに合わせて画像のサイズを調整します。

使い方

1.画像の貼り付け先になる枠をワークシート上に用意する。(任意)

2.マクロを実行する。

3.ファイルを開くダイアログから任意の画像を1枚または複数選択する。

4.選択した画像がワークシート上に挿入される。

5.終了

ポイント

このサンプルでは、次の4つのパターンに対応しています。

1.離れた結合セル

2.離れた非結合セル

3.連続した非結合セル

4. 1,2が混在している場合

貼り付け先のセルが離れている隣接しているかで処理が異なります。

判定だけしてくれる関数やプロパティが見つからなかったので、とりあえず、

Selection.Areas.Count

で、選択されているセルに含まれる非連続範囲(離れて存在する範囲)の数を調べます。

「セルの数」ではなく「範囲の数」であることが重要です。選択されているセルが結合セル(例えば、A1:B2)の場合は、その結合セルを一つの範囲(Areas.Item(index))として扱えます。

セルが隣接している場合は、

Selection.Cells.Count

によって、選択されている範囲の一つ一つのセルを個別の範囲(Cells.Item(index))として扱えます。

このサンプルでは隣接した結合セルは未対応です。気が向いたらやってみますが。

ソースコード

Sub InsertImageToWorksheet()

    Dim targetWorkSheet As Worksheet: Set targetWorkSheet = ActiveSheet

    Dim targetRanges() As Range, couterIndex As Long, rangeCount As Long
 

    If Selection.Areas.Count > 1 Then '非連続(離れた)セルが選択されている場合

        rangeCount = Selection.Areas.Count

        ReDim targetRanges(rangeCount)

        For counterIndex = 1 To rangeCount

            Set targetRanges(counterIndex - 1) = Selection.Areas.Item(counterIndex)

        Next

    Else '連続(隣り合った)セルが選択されている場合

        rangeCount = Selection.Cells.Count

        ReDim targetRanges(rangeCount)

        For counterIndex = 1 To rangeCount

            Set targetRanges(counterIndex - 1) = Selection.Cells.Item(counterIndex)

        Next

    End If
    'ファイルを開くダイアログ(jpgフィルター、複数選択)から画像ファイルのパスを配列に入れる。

    Dim filePathArray As Variant

    filePathArray = _

        Application.GetOpenFilename(FileFilter:="JPG File, *.jpg", MultiSelect:=True)

    If IsArray(filePathArray) = False Then Exit Sub
 

    For counterIndex = 0 To UBound(targetRanges)

       '画像の数が貼り付け先セルの数より少ない場合のエラー

        On Error GoTo NoMoreImages

        Dim targetRange As Range: Set targetRange = targetRanges(counterIndex)

        Dim imgPath As String: imgPath = filePathArray(counterIndex + 1)

        Dim imgMargin As Double: imgMargin = 0 '余白(任意で設定)

       '画像をシートに挿入

        targetWorkSheet.Pictures.Insert(Filename:=imgPath).Select

        Dim targetImage As Shape: Set targetImage = targetWorkSheet.Shapes(Selection.Name)
 

        With targetImage

            .LockAspectRatio = True

            '画像のサイズを貼り付け先セルのサイズに合わせる

            If targetRange.Width <= .Width Then .Width = targetRange.Width

            If targetRange.Height <= .Height Then .Height = targetRange.Height
 

            '貼り付け先セルの中央に画像を配置する

            .Left = targetRange.Left + (targetRange.Width - .Width) / 2

            .Top = targetRange.Top + (targetRange.Height - .Height) / 2

            .Placement = xlFreeFloating

            .Placement = xlMove

        End With

    Next

    Exit Sub

NoCellsSelected:

    MsgBox "No cells selected"

    Exit Sub

NoMoreImages:
End Sub
 

#VBA #Excel