LoginSignup
2
4

More than 5 years have passed since last update.

エクセルに写真を一括で張り付けるマクロ

Last updated at Posted at 2018-05-22

下のような台帳に写真を一括で張り付けるマクロ
私が働いている会社は建築系なので、施工前と施工後で2回に分けて張り付けるマクロになっています。
きれいに動作する前提条件としては、結合されているセルの縦、横幅がすべて同じサイズでないと写真の大きさがうまくはまりません。
ありきたりなマクロではありますが何かの参考になれば・・・。

施工後の部分に張り付けるマクロについてはcntの変数を17に設定すれば動きます。
要はセルの開始行番号をcntに設定すればいけます。

エクセルフォーマット.PNG

まずはコードから

写真一括挿入
Sub 一括画像挿入前()
Application.ScreenUpdating = False
On Error Resume Next
Dim yokohaba, tatehaba As Double
Dim place, filename, mo As Variant
Dim fname As String
Dim icount, i, i2, cnt, addcnt As Integer
Dim gazou As Shape

mo = Array("B", "J", "R", "Z")


    i = 1 'filenameに格納されるのが1から
    cnt = 4
    icount = 0
    filename = Application.GetOpenFilename("画像,*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.did;*.rle;*.gif;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg;", MultiSelect:=True)
    If TypeName(filename) = "Variant()" Then  '写真が選択されていればfilenameはvariantの配列型になるはず
        Do While i <> UBound(filename) + 1    '写真の数だけループする +1はfilenameの配列が1番から始まる為
            Range(mo(icount) & cnt).Select
            yokohaba = (ActiveCell.MergeArea.Columns.Count * ActiveCell.Width) - 2
            tatehaba = (ActiveCell.MergeArea.Rows.Count * ActiveCell.Height) - 2
            Set gazou = ActiveSheet.Shapes.AddPicture(filename(i), False, True, Selection.Left + 1, Selection.Top + 1, yokohaba, tatehaba)
            fname = filename(i)

            If fname = filename(i + 1) Then '同じ写真の名前が来たら終了
                Exit Do
            End If

            If i = 40 Then
                MsgBox ("写真が取込きれませんでした")
                End
            End If

            If icount = UBound(mo) Then
                icount = 0
                cnt = cnt + 28
            Else
                icount = icount + 1
            End If

            i = i + 1

        Loop
    Else
        MsgBox ("キャンセルしました")
    End If

    ActiveWindow.SmallScroll Down:=-2000
    Range("A1").Select
    Application.ScreenUpdating = True
flg = 0
End Sub

簡単なコードの解説
1.まずはmoの配列に写真を挿入したいセルの左上の列文字を入れておき、ループで文字を切り替えられるように設定します。
2.i の初期値が1で設定されているのはapplication.getopenfilenameでfilenameの配列に格納されるのが0ではなく1から格納されるため、1を設定しています。
0だと参照先がエラーになる。(On Error Resume Nextが設定されているため、最初のセルがスルーされる)
3.同じ名前の写真が来たら終了という部分だが、ここはOn Error Resume Nextの力を借りて無理やり終了させている節はある。
写真を貼付終わった後、配列を+1するとインデックスがありませんというエラーになり、Resume Nextの力を借りて強制的にExit Doへ進んでしまっている。
コード的には美しくはないが動いているので現状はこれで使用しています。 ここはTypeNameか何かを利用すればスマートに動くと思います。
TypeName(filename(i+1)) = エラー的な処理ができれば・・・。
4.写真が取り込みきれませんでしたのiの部分については写真の最大取込数を数値にて設定してください。

あとがき
コード解説を書いていて3番の問題点に初めて気が付きました・・・。
容易にOn Error Resume Next等々の強制的に処理を進めるように作ってしまうと思わぬところでエラーになりそうだなぁと。
いつかはセルの幅が等幅でなくても写真のサイズをぴったりにできればいいなとは思っています。
コードにはうまく書けないですが、結合しているセルの数を取得して各幅を取得して写真のサイズに当てはめればいけそう・・・?
社内簡易プログラマーのメモ書きでした。

2
4
3

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
2
4