ネットでゴロゴロと出回っている内容ではあるが、備忘録として置いておきます。
ちなみに貼り付け先のセルについては結合されておりなおかつ縦横の幅が等幅であることが条件です。
画像挿入
sub 選択画像挿入()
On Error Resume Next
Dim i As Integer
Dim filename As Variant
Dim gazou As Shape
Dim cell, celladd, cellcnt, cellarry As Variant
i = 1 'filenameに格納されるのが1から
Set cell = Application.InputBox("画像を貼付たいセルを選択してください。" & vbCrLf & "選択した順番に写真が挿入されます。", "選択画像挿入", , , , , , 8)
If TypeName(cell) = "Range" Then 'セルが選択されていればcellはRangeオブジェクトになる
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)
Application.ScreenUpdating = False
If TypeName(filename) = "Variant()" Then
cell.Select '選択されたセルを選択する
celladd = cell.Address '選択されたセルのアドレスを取得
cellarry = Split(celladd, ",") '選択されたセルのアドレスを配列に格納
cellcnt = UBound(cellarry) + 1 '配列の大きさを取得 要は画像の枚数を取得 +1しているのは配列が0から始まる為
Do While i <> cellcnt + 1 '選択されたセルの数だけループする +1はfilenameが1から配列の番号が始まっている為
Range(cellarry(i - 1)).Select '-1しているのはcellarryは0から、filenameは1から配列の番号が始まる為
If jidou = 2 Then
yokohaba = Range(cellarry(i - 1)).Width * Range(cellarry(i - 1)).MergeArea.Columns.Count '現在の書式は列幅は等倍だから単純にかけている必要に応じて変更
tatehaba = Range(cellarry(i - 1)).Height * Range(cellarry(i - 1)).MergeArea.Rows.Count
End If
Set gazou = ActiveSheet.Shapes.AddPicture(filename(i), False, True, Selection.Left, Selection.Top + 1, yokohaba, tatehaba)
i = i + 1
Loop
Else
MsgBox ("キャンセルしました")
End If
Else
MsgBox ("キャンセルしました")
End If
ActiveWindow.SmallScroll Down:=-2000
Range("A1").Select
Application.ScreenUpdating = True
あとがき
自分で作っといてあれですが、どういう動きをしているか全くわからなくなってしまいました。
恐らくSplitで配列に一気にセル番地をcellarryに叩きこんでWhileで回して画像をセットしているはずなのだが・・・。
どこかのサイト様を参照して作ったはずだがこれも忘れてしまった・・・。
もし色々と引っかかるものがございましたらご指摘ください。すぐに消します。