0
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 5 years have passed since last update.

VBAで指定したセルに写真を一括で張り付けるマクロ

0
Last updated at Posted at 2018-05-22

ネットでゴロゴロと出回っている内容ではあるが、備忘録として置いておきます。
ちなみに貼り付け先のセルについては結合されておりなおかつ縦横の幅が等幅であることが条件です。

画像挿入
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で回して画像をセットしているはずなのだが・・・。
どこかのサイト様を参照して作ったはずだがこれも忘れてしまった・・・。
もし色々と引っかかるものがございましたらご指摘ください。すぐに消します。

0
2
0

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
0
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?