[[20190920113524]]　『画像一括挿入ＶＢＡ』（ねむねむ）　ページの最後に飛ぶ

『画像一括挿入ＶＢＡ』（ねむねむ）

エクセルで指定フォーマットへ画像をフォルダごと挿入したいです。
工事写真の為、場所によって枚数が異なり少ない所だと10枚くらいなのですが多い所は100枚以上あるので1シートに9枚でシートを必要分だけ勝手に増やし挿入できればと思っています。

フォーマットの画像貼り付け位置はＡ7からＦ24がセルの結合をされていて以降4行ごとに同じ大きさで結合されているのでそこに貼り付けたいです。
写真の大きさはセルのサイズに合うようにしたいです。
画像貼付のみのＶＢＡはできたのですがシートを増やしたりするのがわからなくて…
わかりにくい説明ですがどなたか教えてください

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

いまの時点でできている分のコードを貼ってもらえるとありがたいのですが・・・
（mori） 2019/09/20(金) 12:34

編集がかぶったけどそのまま。

回答ではないですが、
＞画像貼付のみのＶＢＡはできたのですがシートを増やしたりするのがわからなくて…
現状のコードを見せてもらった方が説明しやすいかも。

あと、ニックネームが常連回答者さんと被っているので変えたほうがよいかも。

（もこな２） 2019/09/20(金) 12:38

いまの時点のコードも引用しただけですが貼りつけます。

（もこな２）さん　ニックネーム知りませんでした。変えます。

Sub 複数画像の挿入()

    Dim a, c, sr, sc, s, rr, pkfile, ar, ac, z, rc, ccc, ca0
On Error GoTo err
    Set a = Application.InputBox("画像を挿入するセルを選択してください" _
            & Chr(13) & Chr(10) & "複数選択可 (ShiftキーまたはCtrlキーで選択)" _
         , "複数画像の一括挿入（セル選択）", Selection.Address, , , , , 8)
    Application.ScreenUpdating = False
         a.Select
        sr = Selection.Row
        sc = Selection.Column
    rr = sr
pkfile = Application.GetOpenFilename _
    ("すべての図(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif), *.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif", 2, "挿入する図の選択（複数選択可）", , True)
If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End
    For fi = 1 To UBound(pkfile)
       If pkfile(fi) = False Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End 'キャンセルの場合終わる
    Next fi
n = ActiveSheet.Pictures.Count
Application.DisplayAlerts = False
z = MsgBox("画像のサイズをセルに合わせますか", vbYesNo, "複数画像の挿入")
ok = 0
If Application.Version < 12 Then
    If MsgBox("縦横比を保持しますか", 4, "複数画像の一括挿入") = 6 Then ok = 0 Else ok = 1
End If
If z = 6 Then ya = MsgBox("画像圧縮しますか", vbYesNo, "複数画像の挿入")
    l = MsgBox("元の画像へのリンクを作成しますか", 4 + 256)

  ar = a.Address
 ac = Range(ar).Count
fi = 1
  If ac > 1 Then GoTo ech Else GoTo pc
ech:
    ca0 = ""
   For Each cc In ActiveSheet.Range(ar)
    ca = Range(cc.Address).MergeArea.Address
    rc = Range(ca).Rows.Count
    ccc = Range(ca).Columns.Count
    If rc > 1 Or cc > 1 Then
    ca = Cells(Range(ca).Row + rc - 1, Range(ca).Column + ccc - 1).Address
    End If
    If ca0 = ca Then GoTo mne
    ca0 = ca
    ca = Range(cc.Address).MergeArea.Address
    Range(ca).Select

' cc.Select

        g = ActiveSheet.Shapes.AddPicture( _
            Filename:=pkfile(fi), _
             LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=Selection.Left, _
            Top:=Selection.Top, _
            Width:=400#, _
            Height:=300#).Name
'図のサイズを元のサイズに戻します

    With ActiveSheet.Shapes(g)
        .ScaleHeight 1!, msoTrue
        .ScaleWidth 1!, msoTrue
    End With

        fl = pkfile(fi)
'右のセルにファイル名を表示
        Cells(Range(ca).Row, Range(ca).Column + 1) = fl

        If z = 6 Then セルにサイズを合わせる
        fi = fi + 1
    If fi = UBound(pkfile) + 1 Then GoTo en
mne:
    Next
    Application.DisplayAlerts = True
    a.Select
Exit Sub

pc:

    For fi = 1 To UBound(pkfile)
        ca = Cells(rr, sc).Address
        Range(ca).Select
        g = ActiveSheet.Shapes.AddPicture( _
            Filename:=pkfile(fi), _
             LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=Selection.Left, _
            Top:=Selection.Top, _
            Width:=400#, _
            Height:=300#).Name
'図のサイズを元のサイズに戻します

    With ActiveSheet.Shapes(g)
        .ScaleHeight 1!, msoTrue
        .ScaleWidth 1!, msoTrue
    End With

        fl = pkfile(fi)
'右のセルにファイル名を表示
        Cells(Range(ca).Row, Range(ca).Column + 1) = fl

        If z = 6 Then セルにサイズを合わせる
        rr = rr + 1
    Next fi
Exit Sub
en:
Application.DisplayAlerts = True
    Application.ScreenUpdating = False

    a.Select
Exit Sub
err: MsgBox "選択が正しくありません", , "複数画像の一括挿入"
End Sub

Sub セルにサイズを合わせる()

    Dim c As Range, cm As Range
    Dim rX As Single, rY As Single, r As Single

    Application.ScreenUpdating = False
'    For Each c In Selection

' Set cm = c.MergeArea

        Set cm = Range(ca)
'        If c.Address = cm.Item(1).Address Then
 '           If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub
         ActiveSheet.Shapes(g).Select
           With Selection
                rX = cm.Width / .Width
                rY = cm.Height / .Height
                If ok = 0 Then
                    If rX < rY Then
                         cx = .Width * rX
                         cy = .Height * rX
                    Else
                         cx = .Width * rY
                         cy = .Height * rY
                    End If
                Else
                 cx = cm.Width
                 cy = cm.Height
                 End If
                    .Width = cx
                    .Height = cy
                    .Left = cm.Left
                    .Top = cm.Top + cm.Height - .Height
               If ya = 6 Then 図の圧縮
            End With
 '       End If
 '  Next
    Set cm = Nothing
    Application.ScreenUpdating = True
End Sub
Sub 図の圧縮()
    Selection.Cut
    Range(ca).Select
    ActiveSheet.PasteSpecial Format:="図 (JPEG)"
        If l = 6 Then
           ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=fl
           Else
            Cells(Range(ca).Row, Range(ca).Column + 1) = ""
        End If
        g = Selection.ShapeRange.Name

End Sub

（さぼさん） 2019/09/20(金) 13:14

 モジュールレベルの変数宣言が抜けていませんか？

（渡辺ひかる） 2019/09/20(金) 13:30

（渡辺ひかる）さん

Dim n, fi, cc As Range, ya, ca, g, ok, fl, l

こちらでしょうか？
初心者で全くわかっていないのですみません。
（さぼさん） 2019/09/20(金) 14:35

 やっぱり　変数宣言がありましたか

 久しぶりに見る　スパゲティコードですね。

 途中まで解読したのですが、疲れました

 質問者さんが書いたコードでないなら、まずは　コードで何をしているかを
 調べるほうが先だと思いますよ。

 仮に、ここで複数シート対応ができても、それっきりになってしまいますし。

（渡辺ひかる） 2019/09/20(金) 15:42

コメント返信：

[ 一覧(最新更新順) ]

[[20190920113524]] 『画像一括挿入ＶＢＡ』（ねむねむ） ページの最後に飛ぶ

[[20190920113524]]　『画像一括挿入ＶＢＡ』（ねむねむ）　ページの最後に飛ぶ