Excel VBA シート上に既に存在する画像をセルに合わせてトリムしピッタリ収めるマクロ
シート上に既にある画像を、選択したセルの大きさに合わせてトリムしピッタリおさめるマクロです。
使い方
1. 任意のセルを選択する。（手動）
2. 右クリックメニューからユーザーフォームを開く。
3. 任意の画像を選択する。（手動）
4. ユーザーフォームの実行ボタンを押す。
5. セルの大きさに合わせてトリムされた画像が貼り付けられる。
6. 終了
サンプルのダウンロードはこちらから
ポイント
1．処理は2段階に
セルと画像を同時に選択することができないため、選択されたセルに対する処理と選択された画像に対する処理を分けます。
まず、手動でセルを選択、次に右クリックメニューからユーザーフォームを表示、手動で画像を選択、最後にユーザーフォームを通じてマクロを実行します。
画像を選択時に右クリックからユーザーフォームを表示させ、RangeRangeRefコントロールでセルを選択させるのが王道ですが、「RangeRefコントロールが使えないエラーが発生した」「Excel 2010以降では画像上での右クリックメニューの表示には別のエディターを使ってxmlファイルを書かないといけない」という理由で今回の方法を採りました。
2. 離れたセルの選択範囲を扱い、かつ、結合・非結合セルが混在した範囲を扱う
Excelにおいて、セルの選択範囲が複数存在し、それぞれが互いに離れた位置に存在する場合、それぞれのセル選択範囲は個別のAreaとして扱われます。選択範囲が隣り合っている場合は、同一のAreaとして扱われます。例えば、A1とC1というように離れたセルを選択した場合、A1で一つのArea、C1 で一つのAreaとして扱われ、A1とB1というように隣り合ったセルを選択した場合は、A1:B1が一つのAreaとして扱われるわけです。
このサンプルでは、青(枠番号1-7)で1つのArea、紫（枠番号8-12)で1つのArea、合計2つのAreaが存在します。このように複数のAreaを参照する式がSelection.Areasです。このサンプルでは、青のAreaと紫のAreaはそれぞれ、Selection.Areas(1)、Selection.Areas(2)で参照することができます。
さて、Areaの中には、複数のセルで成る結合セルと単独のセルが混在している可能性があります。サンプルでは、For itemCounter = 1 To currentArea.Cells.Count によってそれぞれのArea内に存在するセル一つ一つのセルを検証し、[Range].MergeCells を使って、結合セルかどうかを判別します。
非結合セルの場合は、画像の貼り付け先の一つとしてそのままRange型配列（targetRanges)に入れます。結合セルの場合は、[Range].MergeArea.Address を使って結合セルの範囲を取得し、その範囲を画像の貼り付け先の一つとしてRange型配列（targetRanges)に入れます。
ここで問題なのが、結合セルに内包されているすべてのセルに上記の処理が行われるため、その数だけ同じ結合セルの範囲が変数に格納されてしまうことです。
例えば、結合セル A1:A2 の場合、まずA1から画像の貼り付け先RangeであるA1:A2を取得し、その後A2からまたA1:A2を取得することになり、貼り付け先が重複してしまいます。
このサンプルでは、画像の貼り付け先Rangeを格納した配列（targetRanges)からAddressを取り出して、カンマ区切りの文字列として結合するループ処理をしてます。その際に結合セルについては、Replace関数を使用して重複の問題を解決しています。カンマ区切り文字列(rangeString)に含まれる、該当Rangeの文字列（tmpString)を空白に置き換え、結合セル内の最後のRangeから取得されるAddressのみが残るようにしています。Replace(rangeString, tmpString, "")
もっとエレガントな方法があるはずですが、思いつきませんでした。
3．コンテクストメニュー（右クリックメニュー）を使う
今回は、利便性を考え、コンテクストメニューからマクロを実行できるアドインにしてみました。
コンテクストメニューの説明の前に、全体の処理の流れをもう少し詳しく説明すると、こんな感じです。
(1) 画像の貼り付け先範囲を手動で選択
(2) 右クリック
(3) 選択範囲を取得・文字列に変換（getSelectedRangesString）
(4) ユーザーフォームのラベルに文字列を表示させる
(5) 画像を手動で選択
(6) ユーザーフォームの実行ボタンを押す
(7) 画像のトリムとフィットを行うルーチン(trimImageOnSheet)に選択範囲（targetRange）と画像（targetImage)を渡す。
下はコンテクストメニューの追加用ソースコードです。標準モジュールに貼り付けて下さい。
Sub setContextMenu() Dim cb As CommandBar Set cb = Application.CommandBars("Cell") cb.Reset With cb.Controls.Add(before:=1, Type:=msoControlPopup) .Caption = "Image" With .Controls.Add .Caption = "Trim image to cell" .OnAction = "showFrmTrimImage" .FaceId = 6827 End With End With End Sub
ThisWorkbookモジュールのWorkbook.Openイベントに Call setContextMenu と書き、addIn形式で保存します。あとは、開発リボンの「Excelアドイン」の有効なアドインから当該アドインをチェックすればアドインとして使えるようになります。アドインについて詳しい解説はググって下さい。
4．ユーザーフォームで制御
フォーム起動時にgetSelectedRangesStringで選択範囲を文字列として取得し、フォームのlblSelectedRangeのCaptionに表示させます。
余白の設定などおまけがついてますが、解説は割愛します。
実行ボタンを押すと、blSelectedRangeのCaptionに表示されている文字列から、画像の貼り付け先RangeをSplit関数で取り出し、Range型配列に格納します。また、選択中の画像をShpe型配列に格納します。さらに、この2つの配列をループしながら、trimImageOnSheetに渡し、拡大縮小・切り取り・配置を行います。
ソースコード （ThisWorkBookに貼り付け）
Private Sub Workbook_Open() Call setContextMenu End Sub
ソースコード （標準モジュールに貼り付）
'---------------------------------------------------------- ' コンテクストメニューコマンド Trim image to cell の設定 '----------------------------------------------------------
Sub setContextMenu() Dim cb As CommandBar Set cb = Application.CommandBars("Cell") cb.Reset With cb.Controls.Add(before:=1, Type:=msoControlPopup) .Caption = "Image" With .Controls.Add .Caption = "Trim image to cell" .OnAction = "showFrmTrimImage" .FaceId = 6827 End With End With End Sub
'---------------------------------------------------------- ' コンテクストメニューコマンド Trim image to cell 起動時の処理 '---------------------------------------------------------- Sub showFrmTrimImage() With frmTrimImage .lblWB.Caption = ActiveWorkbook.Name .lblWS.Caption = ActiveSheet.Name
' 選択中の範囲を文字列として取得します。 .lblSelectedRange.Caption = getSelectedRangesString(ActiveSheet) .Show modeless End With End Sub
'---------------------------------------------------------- ' 選択範囲を文字列にして返す '---------------------------------------------------------- Function getSelectedRangesString(targetSheet As Worksheet) As String Dim currentArea As Range Dim targetRanges() As Range Dim rangeCounter As Long Dim itemCounter As Long
For Each currentArea In Selection.Areas For itemCounter = 1 To currentArea.Cells.Count If currentArea.Item(itemCounter).MergeCells Then ReDim Preserve targetRanges(rangeCounter) '選択範囲をひとまとめにして、Range型配列に入れる Set targetRanges(rangeCounter) = _ targetSheet.Range(currentArea.Item(itemCounter).MergeArea.Address(False, False)) rangeCounter = rangeCounter + 1 Else ReDim Preserve targetRanges(rangeCounter) Set targetRanges(rangeCounter) = _ targetSheet.Range _ (currentArea.Item(itemCounter).Address(False, False)) rangeCounter = rangeCounter + 1 End If Next Next
'<ここまで>選択セル範囲を変数に入れる '---------------------------------------------------------- '<ここから>選択セル範囲の文字数を調べる Dim rangeString As String Dim tmpString As String For rangeCounter = 0 To UBound(targetRanges) tmpString = ", " & targetRanges(rangeCounter).Address(False, False) rangeString = Replace(rangeString, tmpString, "") rangeString = rangeString & tmpString Next rangeString = Mid(rangeString, 3, Len(rangeString)) If Len(rangeString) > 255 Then MsgBox "選択セルが多すぎます" Exit Function End If getSelectedRangesString = rangeString End Function
'---------------------------------------------------------- ' シート上の画像をトリムして選択範囲に挿入する '---------------------------------------------------------- Sub trimImageOnSheet(targetRange As Range, targetImage As Shape, _ 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 '------------------------------------------------- '＜ここから＞画像サイズを選択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
ソースコード （frmTrimImageのイベントプロシージャーに貼り付け）
Private Sub cmdCancel_Click() Unload Me End Sub
Private Sub cmdRun_Click() Dim ws As Worksheet Set ws = Workbooks(Me.lblWB.Caption).Sheets(Me.lblWS.Caption) Dim rangeString As String: rangeString = Me.lblSelectedRange.Caption Dim targetShapes() As Shape, imgCounter As Long On Error GoTo errorHundler Dim selectedShapes As ShapeRange: Set selectedShapes = Selection.ShapeRange Dim targetRanges As Variant: targetRanges = Split(rangeString, ",") Dim tgtShapeCounter As Long For imgCounter = 1 To selectedShapes.Count If imgCounter > UBound(targetRanges) + 1 Then Exit For If selectedShapes(imgCounter).Type = msoPicture Then ReDim Preserve targetShapes(tgtShapeCounter) Set targetShapes(tgtShapeCounter) = selectedShapes(imgCounter).Duplicate tgtShapeCounter = tgtShapeCounter + 1 End If Next Dim targetRange As Range, targetShape As Shape, rangeCounter As Long Dim margin As Double: margin = Me.txtMargin.Value For rangeCounter = 0 To UBound(targetRanges) If rangeCounter > UBound(targetShapes) Then Exit For Set targetRange = ws.Range(targetRanges(rangeCounter)) Set targetShape = targetShapes(rangeCounter) Call trimImageOnSheet(targetRange, targetShape, margin, margin) Next ws.Range("A1").Select If Me.chkSelect Then For imgCounter = 0 To UBound(targetShapes) targetShapes(imgCounter).Select Replace:=False Next End If Unload Me Exit Sub errorHundler: MsgBox "画像が選択されていません。" End Sub
Private Sub lblReload_Click() Me.lblSelectedRange.Caption = getSelectedRangesString(ActiveSheet) End Sub
Private Sub spnMargin_SpinUp() Me.txtMargin.Value = Me.txtMargin.Value + 1 End Sub Private Sub spnMargin_SpinDown() Me.txtMargin.Value = Me.txtMargin.Value - 1 End Sub Private Sub txtMargin_Change() If IsNumeric(Me.txtMargin.Value) = False Then Me.txtMargin.Value = 0 End If If Me.txtMargin.Value < 0 Then Me.txtMargin.Value = 0 End If If Me.txtMargin.Value >= 5 Then Me.txtMargin.Value = 5 End If End Sub
