Office TANAKA - Excel VBA Tips[画像を揃える]

ワークシートに挿入した画像はPictureオブジェクトで表されます。まぁ、正確にはPictureオブジェクトではないんですけど、そのへんは「画像を挿入する」をご覧ください。で、そのPictureオブジェクトには、上位置を表すTopプロパティと、左位置を表すLeftプロパティがあります。両者を指定することで、挿入した画像の位置を指定できます。ちょっと、やってみましょうか。次のコードは、セルB3に画像を挿入します。

Sub Macro1()
    With ActiveSheet.Pictures.Insert("C:\Work\Sample2.jpg")
        .Top = Range("B3").Top
        .Left = Range("B3").Left
    End With
End Sub

写真は、みなさんお馴染み、青森の「田酒」です。しかも！ただの田酒ではありません！弁慶米100%という、まさに幻の逸品。通称"田酒の赤ラベル"です。ほとんど流通しない貴重なお酒です。いやぁ～美味かったぁ～(^▽^)

え～と、何でしたっけ？あ、そっか画像ね。このように、TopプロパティとLeftプロパティで位置を指定できるんですが、問題は2枚目です。次の画像を、この1枚目の画像と揃えて表示したいと。実務では"あるある"ですね。

別の画像にピタリと合わせる

もし、次の画像を、すでに挿入している画像に、ピタリとくっつけて挿入したいのでしたら、次のように考えます。

まずは、既存画像の「真下」に挿入してみます。であれば、画像の左位置は、既存画像と同じです。

Sub Macro2()
    With ActiveSheet.Pictures.Insert("C:\Work\Sample3.jpg")
        .Top = 既存画像の真下
        .Left = ActiveSheet.Pictures(1).Left
    End With
End Sub

「Pictures(1)」というのは、位置の基準としている既存画像が、アクティブシートに1枚だけ存在しているという意味です。もし、複数の画像がアクティブシート上に挿入されていたら、この基準となる既存画像を"何とかして"特定します。さて、問題は「真下」の位置です。これは、次のようにすれば計算できます。

既存画像の「真下」ということは、既存画像のTop(上位置)と、既存画像のHeight(高さ)を足したところです。

Sub Macro2()
    With ActiveSheet.Pictures.Insert("C:\Work\Sample3.jpg")
        .Top = ActiveSheet.Pictures(1).Top + ActiveSheet.Pictures(1).Height
        .Left = ActiveSheet.Pictures(1).Left
    End With
End Sub

でました！作です！しかもクラウン！その名も「筰(ザククラウン)」三重県鈴鹿は清水清三郎商店の内山杜氏が、その持てる力を惜しみなく注ぎ込んだという、渾身の自信作。贅沢な原料をふんだんに使い、仕込みに必要なすべての工程で手間暇を惜しまず、一滴一滴、丁寧に搾った最高品質のお酒です。一口含んだ途端に口いっぱいに広がる華やかで奥深い香りは、まさに"芸術品"。ラベルは三重の伝統工芸「伊勢和紙」を「鈴鹿墨」で染めた「染め和紙」です。「伊勢和紙」とは、神宮御用紙として伊勢神宮の神札などに使われている清浄な和紙。その和紙を、平安時代から続くと言われる高品質の墨「鈴鹿墨」で、一枚一枚丁寧に染め上げられています。伝統の和紙と繊細なグラデーションが、これ以上ない気品を漂わせます。750mlで35,000円近い金額もさることながら、全国で限定120本という超貴重酒。これ、次回はない、もう一生飲めない銘酒です。ちなみに、あまりに美味しいので調子に乗って何杯も飲んだら、とんでもない金額になりましたっけww(^▽^)

え～と、何でしたっけ？あ、そっか画像ね。はいはい...

既存画像の右に挿入するのも考え方は同じです。今度は、Topは既存画像と同じです。で、左位置(Left)は、既存画像の「Left + Width」です。

Sub Macro3()
    With ActiveSheet.Pictures.Insert("C:\Work\Sample3.jpg")
        .Top = ActiveSheet.Pictures(1).Top
        .Left = ActiveSheet.Pictures(1).Left + ActiveSheet.Pictures(1).Width
    End With
End Sub

ちなみに、見てお分かりのように、2枚の画像は元のサイズが同じです。一般的に、同じデジカメやスマホなどで撮影した画像は、同じサイズで保存されます。ですから、こうして並べたときにも違和感はありません。もし、挿入する画像のサイズが異なっていたら、並べるとピッタリ揃いません。当たり前です。そうした"画像の元サイズ"を、VBAで何とか調整したり変更したりしようと試みる人がいますが、やめた方がいいです。理由は明白です。VBAは「何でもできる魔法の道具」ではなく、表計算ソフトであるExcelを操作するための"マクロ言語"に過ぎないからです。何でもできるわけじゃありません。そこを勘違いしている人が、実に多いです。複数の画像ファイルを、すべて同じ大きさに変更するような操作は、VBAではなく、フリーのオンラインソフトなどを使った方がはるかに簡単です。そうして、サイズを揃えた上で読み込みます。何でもかんでも、VBAだけでやろうとしないでください。

セルに合わせる

画像をピタリとくっつけて表示すると、逆に見にくくなるかもしれません。画像の間隔を、少し開けるというのも、よくある話ですね。上記の考え方で、少しだけ余裕を加えてあげてもいいのですけど、もうひとつ"あるある"のやり方として、セルに合わせるというのも多いことでしょう。たとえば、次のような感じです。

上図では、2枚目の画像が挿入されているセルB16を特定できれば、いいわけです。しかし、1枚目の画像の大きさは分かりません。画像ですから。セルに値が入力されているのではありません。Endモードなどは使えません。さあ、どうしましょう。

画像などのShapeオブジェクトには、そのShapeオブジェクトの左上が乗っているセルを表すTopLeftCellプロパティと、右下が乗っているセルを表すBottomRightCellプロパティがあります。

Sub Macro4()
    With ActiveSheet.Pictures(1)
        MsgBox "左上：" & .TopLeftCell.Address
        MsgBox "右下：" & .BottomRightCell.Address
    End With
End Sub

つまり「左上」セルと「右下」セルから、画像の下のセル(ここではセルB16)を導き出すには、どうしたらいいかということです。

ここでは、2つの方法をご紹介します。

一般的で簡単な方法

まずは簡単な方法から。

今回、新しい画像を挿入するセルは、セルB16です。これ、Cellsで表すと「Cells(16, 2)」です。このうち、列の「2」は左上セル「Cells(3, 2)」の列と同じです。

さらに「Cells(16, 2)」で行を表す「16」は、右下セル「Cells(15, 4)」の行「15」に1を加えた数値です。以上のことから、新しい画像を挿入するセルは

Cells(右下セルの行+1, 左上セルの列)

だと分かります。

右下セルの行 → 画像.BottomRightCellの行 → 画像.BottomRightCell.Row
左上セルの列 → 画像.TopLeftCellの列 → 画像.TopLeftCell.Column
なのですから、まとめると、次のようになります。

Sub Macro5()
    Dim R As Long, C As Long
    R = ActiveSheet.Pictures(1).BottomRightCell.Row
    C = ActiveSheet.Pictures(1).TopLeftCell.Column
    With ActiveSheet.Pictures.Insert("C:\Work\Sample3.jpg")
        .Top = Cells(R + 1, C).Top
        .Left = Cells(R + 1, C).Left
    End With
End Sub

まぁ、普通にやるなら、この方法でしょうね。

ちょっとマニアックな方法

ApplicationオブジェクトのIntersectメソッドは、複数のセル範囲の共有セルを返します。

ここでは、「左上」セルを含む列全体と「右下」セルを含む行全体の中で共有しているセルを求めます。

目指すセルは、この共有セルの1つ下のセルです。

Sub Macro6()
    Dim Target As Range
    With ActiveSheet.Pictures(1)
        Set Target = Application.Intersect(.TopLeftCell.EntireColumn, .BottomRightCell.EntireRow).Offset(1, 0)
    End With
    With ActiveSheet.Pictures.Insert("C:\Work\Sample3.jpg")
        .Top = Target.Top
        .Left = Target.Left
    End With
End Sub

意味が分からない人は、無理をしないで最初の"一般的な方法"で、やってください。