下のような台帳に写真を一括で張り付けるマクロ
私が働いている会社は建築系なので、施工前と施工後で2回に分けて張り付けるマクロになっています。
きれいに動作する前提条件としては、結合されているセルの縦、横幅がすべて同じサイズでないと写真の大きさがうまくはまりません。
ありきたりなマクロではありますが何かの参考になれば・・・。
施工後の部分に張り付けるマクロについてはcntの変数を17に設定すれば動きます。
要はセルの開始行番号をcntに設定すればいけます。
まずはコードから
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等々の強制的に処理を進めるように作ってしまうと思わぬところでエラーになりそうだなぁと。
いつかはセルの幅が等幅でなくても写真のサイズをぴったりにできればいいなとは思っています。
コードにはうまく書けないですが、結合しているセルの数を取得して各幅を取得して写真のサイズに当てはめればいけそう・・・?
社内簡易プログラマーのメモ書きでした。