[[20201019141422]]　『リストの順番にフォルダを自動選択』（eronex）　ページの最後に飛ぶ

『リストの順番にフォルダを自動選択』（eronex）

お世話になります。

１ファイルリストにあるファイルを開いて、
２指定したフォルダから、
３画像を張り付け、
４微修正し、
５保存。

現在、２のフォルダの選択を手動で行っているのですが、
下記のリストに基づいて自動で選択し、写真を張り付けしたいのです。

初級者ですいませんが
よろしくお願い申し上げます。

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
リスト
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
ファイルリストフォルダリスト画像リスト画像リスト
D:\【マクロテスト】￥100.xlsx D:\【マクロテスト】￥1 D:\【マクロテスト】￥1\1.jpg D:\【マクロテスト】￥1\2.jpg
D:\【マクロテスト】￥200.xlsx D:\【マクロテスト】￥2 D:\【マクロテスト】￥2\1.jpg D:\【マクロテスト】￥2\2.jpg
D:\【マクロテスト】￥300.xlsx D:\【マクロテスト】￥3 D:\【マクロテスト】￥3\1.jpg D:\【マクロテスト】￥3\2.jpg
D:\【マクロテスト】￥400.xlsx D:\【マクロテスト】￥4 D:\【マクロテスト】￥4\1.jpg D:\【マクロテスト】￥4\2.jpg
D:\【マクロテスト】￥500.xlsx D:\【マクロテスト】￥5 D:\【マクロテスト】￥5\1.jpg D:\【マクロテスト】￥5\2.jpg

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～

Sub 図面貼り付け()

act = ActiveWorkbook.Name
For i = 2 To 6
Workbooks.Open Range("A" & i)
MsgBox Workbooks(act).ActiveSheet.Range("C" & i)

  Dim folderPath As String

With Application.FileDialog(msoFileDialogFolderPicker)

  If .Show = True Then folderPath = .SelectedItems(1)
End With
If folderPath = "" Then Exit Sub

Range("B11:F41").Select
ActiveSheet.Shapes.AddPicture _
Filename:=folderPath & "\1.jpg", _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Selection.Left + 8.8, _
Top:=Selection.Top + 20.75, _
Width:=-1, _
Height:=-1 'Selection.Width Selection.Height

Range("G11:K41").Select
ActiveSheet.Shapes.AddPicture _
Filename:=folderPath & "\2.jpg", _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Selection.Left + 19.5, _
Top:=Selection.Top + 14.25, _
Width:=-1, _
Height:=-1 'Selection.Width Selection.Height

 Range("E7").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

ActiveWorkbook.Save
ActiveWorkbook.Close
Next

End Sub

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

 配列にリストを取り込んで、配列から
 取り出しながら処理することになると思います。
（OK） 2020/10/19(月) 17:18

前のトピックも同じですが、基本的にExcelVBAの世界では、シートやセルなど（オブジェクトといいます）をきちんと指定すれば、いちいち選択したりアクティブにしたりする必要がありません。
また、【標準モジュール】でRange("A1")　など、シートを指定しない記述をすると、ActiveSheetを指定したものとして扱われます。
したがって、複数のブックやシートを対象にした処理を考えるなら、ちゃんとオブジェクトを指定するようにすることをお勧めします。

また、ブックに複数のシートがある場合、開いたときに想定と違うシートがアクティブになっていることも考えられます。
よって、やはりシート名やIndex番号を使ってシートも明確に指定した方がよいとおもいます。
（シートが１つしかないないなら、１番目のシートを指定すれば良い）

踏まえて、こちらのトピックで提示されたコードを整理してみるとこんな感じになります。
（コンパイルエラーにならないことだけチェックしてます。（動作チェックはしておりません））

    Sub 図面貼り付け_整理()
        Dim MySH As Worksheet
        Dim i As Long
        Dim folderPath As String

        Set MySH = ActiveSheet

        '▼フォルダを選択してもらう
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                folderPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With

        'ループ処理
        For i = 2 To 6
            With Workbooks.Open(Range("A" & i).Value)
                MsgBox MySH.Range("C" & i).Value

                With .Worksheets(1)
                    .Shapes.AddPicture _
                        Filename:=folderPath & "\1.jpg", _
                        LinkToFile:=False, _
                        SaveWithDocument:=True, _
                        Left:=.Range("B11:F41").Left + 8.8, _
                        Top:=.Range("B11:F41").Top + 20.75, _
                        Width:=-1, _
                        Height:=-1

                    .Shapes.AddPicture _
                        Filename:=folderPath & "\2.jpg", _
                        LinkToFile:=False, _
                        SaveWithDocument:=True, _
                        Left:=.Range("G11:K41").Left + 19.5, _
                        Top:=.Range("G11:K41").Top + 14.25, _
                        Width:=-1, _
                        Height:=-1

                    With .Range("E7")
                        .HorizontalAlignment = xlLeft
                        .VerticalAlignment = xlCenter
                        .WrapText = False
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = 0
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        .MergeCells = False
                    End With
                End With

                .Save
                .Close
            End With
        Next i
    End Sub

質問のほうは、上記を眺めてみて（場合によってはステップ実行してみて）どの部分が変われば目的が達成できるか考えてみては如何でしょうか？

（もこな２） 2020/10/19(月) 17:38

もこな２様

回答ありがとうございます。
超初級者で自動保存などを繰り返し作成しました。
もともとは、複数箇所だけだったのですが、数百箇所に増えました。
そのため、リストを作成しうまくループできないものかと。

張り付ける画像は、
同じファイル名なのですが画像データが違います。
※もとはそれぞれ違うファイル名だったのですが
簡単に記述すのが困難なためファイル名を統一しました。

それで、ご指摘の通り、いちいちフォルダを選択するのが面倒なため、
リストを作成し、うまくループできないものかと質問させていただきました。

ファイルリストフォルダリスト画像リスト画像リスト
D:\【マクロテスト】\100.xlsx D:\【マクロテスト】\1 D:\【マクロテスト】\1\1.jpg D:\【マクロテスト】\1\2.jpg
D:\【マクロテスト】\200.xlsx D:\【マクロテスト】\2 D:\【マクロテスト】\2\1.jpg D:\【マクロテスト】\2\2.jpg
D:\【マクロテスト】\300.xlsx D:\【マクロテスト】\3 D:\【マクロテスト】\3\1.jpg D:\【マクロテスト】\3\2.jpg
D:\【マクロテスト】\400.xlsx D:\【マクロテスト】\4 D:\【マクロテスト】\4\1.jpg D:\【マクロテスト】\4\2.jpg
D:\【マクロテスト】\500.xlsx D:\【マクロテスト】\5 D:\【マクロテスト】\5\1.jpg D:\【マクロテスト】\5\2.jpg

お手数おかけしましが
よろしくお願いいたします。

（eronex） 2020/10/20(火) 09:17

なんか話がかみ合っていませんが、「図面貼り付け_整理」は見ていただけたのでしょうか？

要はこうなってますよね？

    Sub 図面貼り付け_整理簡略版()
        Dim i As Long

        'ループ処理
        For i = 2 To 6
            With Workbooks.Open(MySH.Range("A" & i).Value)　　　　          ←★ここで、対象ブックの（フル）パスを指定している
                With .Worksheets(1)
                    .Shapes.AddPicture _
                        Filename:=folderPath & "\1.jpg"　　　　　　    ←★ここで、対象ファイル（１つめの画像）のフルパスを指定している

                    .Shapes.AddPicture _
                        Filename:=folderPath & "\2.jpg"　　　　　　    ←★ここで、対象ファイル（２つめの画像）のフルパスを指定している

                End With
                .Save
                .Close
            End With
        Next i
    End Sub

つまり、★のところがそれぞれ変わればよいということではありませんか？
幸いにして、もともと自ブック?のアクティブシートにリストのようなものがあるようなので、それを拡張すればよいのではないでしょうか？

（もこな２） 2020/10/20(火) 19:27

コメント返信：

[ 一覧(最新更新順) ]

[[20201019141422]] 『リストの順番にフォルダを自動選択』（eronex） ページの最後に飛ぶ

[[20201019141422]]　『リストの順番にフォルダを自動選択』（eronex）　ページの最後に飛ぶ