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

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

使い方

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