Excel VBA シート上に既に存在する画像をセルに合わせてトリムしピッタリ収めるマクロ

最終更新: 3月23日


シート上に既にある画像を、選択したセルの大きさに合わせてトリムしピッタリおさめるマクロです。

使い方

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
 

#ExcelVBA #画像 #トリム