Excel VBA 画像をインポート、セルに合わせてトリムしピッタリ収めるマクロ
インポートした画像をワークシート上の任意のセルにピッタリ合うようにトリムして貼り付けるマクロです。結合セル、連続セル、離れたセルの組み合わせでも機能します。サンプルファイル（xlsm) はこちら
使い方
1. ワークシート上の任意のセルを選択（複数選択可能。結合セルでもOK)
2. マクロ実行
3. 写真を選択
4. 画像がセルのサイズに合わせてトリムされ、ぴったり貼り付けられます。
5. 終了
ポイント
1．結合セル、離れたセルなど、混在した選択範囲を参照する
結合セルが混じったワークシートは見るだけでも嫌なものですが、扱いが上達すれば、他の場面でも応用が効きます。
選択範囲を参照する際は、 Selection ではなく、Selection.Areas を使っています。
結合セルの範囲を扱うのに重宝します。Selection.Areas だと、結合セルの中の個別のセルを気にすることなく、一つのArea「範囲」としてまとめて扱えるので楽です。
For Each currentArea In Selection.Areas '選択範囲が結合セルの場合 If currentArea.MergeCells Then ReDim Preserve targetRanges(rangeCounter) '選択範囲をひとまとめにして、Range型配列に入れる Set targetRanges(rangeCounter) = _ targetSheet.Range(currentArea.Address(False, False)) rangeCounter = rangeCounter + 1 Else
一方、結合されていないセル（非結合セル）が連続（隣接）するArea(範囲)は、一つ一つのセルに画像を埋め込む仕様にしているため、Areaとしてひとまとめに扱われないよう、ばらばらにする必要があります。
下記のように、Area内のセルの数だけループさせて、.Itemで参照し、Range型配列に格納します。
For itemCounter = 1 To currentArea.Cells.Count ReDim Preserve targetRanges(rangeCounter) Set targetRanges(rangeCounter) = _ targetSheet.Range _ (currentArea.Item(itemCounter).Address(False, False)) rangeCounter = rangeCounter + 1 Next
2．画像のトリム
最難関でした。非常に手間取りました。PictureFormat.CropTopや CropLeftなど四方からトリムする方法もあるのですが、上手くいかなかったので、マクロの記録を使って調べていました。理解するのも書くのも、とても煩雑なコードです。
With targetImage .LockAspectRatio = msoFalse 'トリムしたい高さ .IncrementTop heightDiff 'トリム後の高さ / 元の画像の高さ .ScaleHeight imgHeightNew / imgHeight, msoFalse, msoScaleFromTopLeft '元の画像の高さ .PictureFormat.Crop.PictureHeight = imgHeight 'トリムしたい幅 .IncrementLeft widthDiff 'トリム後の幅 / 元の画像の幅 .ScaleWidth imgWidthNew / imgWidth, msoFalse, msoScaleFromTopLeft '元の画像の幅 .PictureFormat.Crop.PictureWidth = imgWidth End With
3．その他
このサンプルでは、処理を単純化するため、一旦、画像の高さや幅をセルに合わせたのちに、トリミングしています。セルや画像の縦横比が極端に偏っている場合を除けば、そこそこ使えそうです。
ソースコード
'読み込んだ画像を、ワークシート上の任意の選択範囲に合わせてトリム・フィットする 'メインルーチン Sub trimFitImageToWorkSheet() Dim filePathArray As Variant filePathArray = _ Application.GetOpenFilename(FileFilter:="JPG Ffile, *.jpg", MultiSelect:=True) If IsArray(filePathArray) = False Then Exit Sub Dim targetSheet As Worksheet: Set targetSheet = ActiveSheet Dim currentArea As Range Dim targetRanges() As Range Dim rangeCounter As Long Dim itemCounter As Long For Each currentArea In Selection.Areas '選択範囲が結合セルの場合 If currentArea.MergeCells Then ReDim Preserve targetRanges(rangeCounter) '選択範囲をひとまとめにして、Range型配列に入れる Set targetRanges(rangeCounter) = _ targetSheet.Range(currentArea.Address(False, False)) rangeCounter = rangeCounter + 1 Else '非結合セルが隣接して選択されている場合も、範囲としてひとまとめに扱われてしまうため、 'ここでは、選択範囲内のセルを .Item で取得し、ばらばらにしてRange型配列に入れる。 For itemCounter = 1 To currentArea.Cells.Count ReDim Preserve targetRanges(rangeCounter) Set targetRanges(rangeCounter) = _ targetSheet.Range _ (currentArea.Item(itemCounter).Address(False, False)) rangeCounter = rangeCounter + 1 Next End If Next Dim imagePath As String Dim targetRange As Range For rangeCounter = 0 To UBound(targetRanges) '写真が足りなくなったら抜ける If rangeCounter >= UBound(filePathArray) Then Exit Sub imagePath = filePathArray(rangeCounter + 1) Set targetRange = targetRanges(rangeCounter) '画像をトリムしてセルにフィットさせるサブルーチンへ。対象Rangeと画像のパス、余白を引数にする。 Call trimImageForCells(targetRange, imagePath, 2, 2) Next End Sub
'読み込んだ画像を、ワークシート上の任意の選択範囲に合わせてトリム・フィットする 'サブルーチン Sub trimImageForCells(targetRange As Range, imagePath As String, _ Optional marginWidth As Double, Optional marginHeight As Double) Dim targetWS As Worksheet: Set targetWS = targetRange.Parent '選択されているRangeのサイズを取得 Dim rangeWidth As Double: rangeWidth = targetRange.Width Dim rangeHeight As Double: rangeHeight = targetRange.Height '画像を挿入する。画像サイズと位置はとりあえず０に設定する Dim targetImage As Shape: Set targetImage = _ targetWS.Shapes.AddPicture(imagePath, msoFalse, msoTrue, 0, 0, 0, 0) '縦横の比率を保持したまま、画像を元の大きさに戻す targetImage.ScaleHeight 1, msoTrue targetImage.ScaleWidth 1, msoTrue '------------------------------------------------- '＜ここから＞画像サイズを選択Range以上に設定する '------------------------------------------------- '画像のサイズを取得 Dim imgWidth As Double: imgWidth = targetImage.Width Dim imgHeight As Double: imgHeight = targetImage.Height '画像の縦横比率を固定 targetImage.LockAspectRatio = msoTrue '画像の高さを選択Rangeの高さに合わせる targetImage.Height = rangeHeight imgWidth = targetImage.Width '画像の幅が選択Rangeの幅より小さい場合は、 '画像の幅を選択Rangeの幅よりに合わせる If imgWidth < rangeWidth Then targetImage.Width = rangeWidth End If imgHeight = targetImage.Height imgWidth = targetImage.Width '------------------------------------------------- '＜ここまで＞画像サイズを選択Range以上に設定する '------------------------------------------------- '選択されているRangeのサイズと画像のサイズの差異を取得 Dim widthDiff As Double: widthDiff = imgWidth - rangeWidth Dim heightDiff As Double: heightDiff = imgHeight - rangeHeight 'Rangeと画像のマージンを設定 widthDiff = widthDiff + marginWidth heightDiff = heightDiff + marginHeight '調整後の画像のサイズ Dim imgWidthNew As Double: imgWidthNew = imgWidth - widthDiff Dim imgHeightNew As Double: imgHeightNew = imgHeight - heightDiff
'画像のトリム With targetImage .LockAspectRatio = msoFalse 'トリムしたい高さ .IncrementTop heightDiff 'トリム後の高さ / 元の画像の高さ .ScaleHeight imgHeightNew / imgHeight, msoFalse, msoScaleFromTopLeft '元の画像の高さ .PictureFormat.Crop.PictureHeight = imgHeight 'トリムしたい幅 .IncrementLeft widthDiff 'トリム後の幅 / 元の画像の幅 .ScaleWidth imgWidthNew / imgWidth, msoFalse, msoScaleFromTopLeft '元の画像の幅 .PictureFormat.Crop.PictureWidth = imgWidth End With '選択範囲に画像を配置する With targetImage .Left = targetRange.Left + (rangeWidth - .Width) / 2 .Top = targetRange.Top + (rangeHeight - .Height) / 2 .Placement = xlFreeFloating .Placement = xlMove End With End Sub
