[[20211114090213]]　『フォルダ内のエクセルを選択し、選択したエクセル』（P）　ページの最後に飛ぶ

『フォルダ内のエクセルを選択し、選択したエクセルデータを転記するプログラム』（P）

VBAにて教えて頂きたいです。
押しボタンで、転記するエクセルをフォルダ内のエクセルを選択します。
選択したエクセルの
情報１シートから、A列、F列、B列、G列、AA列　
情報2シートからAA列のデータを読み取り、
転記先のデータ１シートにB列、C列、D列、E列、F列、G列に転記できるVBAを考えています。
情報1シート、情報2シートからの抜出しがわからなくて困っています。
教えて頂けないでしょうか。

Sub 取込み実行_Click()
Dim wb As Workbook
Dim sh As Worksheet
Dim Rout As Long
Dim FilePath As String 'パス＆ファイル名
Dim FileName As String
FilePath = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
Rout = 7
Do While FileName <> ""If FileName <> ThisWorkbook.Name ThenSet wb = Workbooks.Open(ThisWorkbook.Path & "\" & FileName, False, True)Set

sh1 = Workbooks.Worksheets("情報1")
Set sh2 = Workbooks.Worksheets("情報2")
For Each sh1,sh2 In wb.Worksheets
With ThisWorkbook.Worksheets("データ1")
.Cells(Rout+1, "B").Value = sh1.Range(Rout, "A").Value
.Cells(Rout+1, "C").Value = sh1.Range(Rout, "F").Value
.Cells(Rout+1, "D").Value = sh1.Range(Rout, "B").Value
.Cells(Rout+1, "E").Value = sh1.Range(Rout, "G").Value
.Cells(Rout+1, "F").Value = sh1.Range(Rout, "AA").Value
.Cells(Rout+1, "G").Value = sh2.Range(Rout, "AA").Value
End With
Rout = Rout + 1
Next sh
wb.Close False
End If
FileName = DirLoop
MsgBox "処理終了"
End Sub

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

とりあえず、提示のコードだと必要な改行等がないため、構文エラーになってますよね。
まずはそちらを修正してみてはどうですか？

そのうえで、【ステップ実行】して思う通りいってないところを探ってみてはどうでしょうか？

    Sub 修正1()
        Dim wb As Workbook
        Dim sh As Worksheet
        Dim Rout As Long
        Dim FilePath As String 'パス＆ファイル名
        Dim FileName As String

        FilePath = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
        FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
        Rout = 7
        Do While FileName <> ""
            If FileName <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & FileName, False, True)
                Set sh1 = Workbooks.Worksheets("情報1") '★要修正
                Set sh2 = Workbooks.Worksheets("情報2") '★要修正

                For Each sh In wb.Worksheets   '★「sh1,sh2」を「sh」に修正
                    With ThisWorkbook.Worksheets("データ1")
                        .Cells(Rout + 1, "B").Value = sh1.Range(Rout, "A").Value
                        .Cells(Rout + 1, "C").Value = sh1.Range(Rout, "F").Value
                        .Cells(Rout + 1, "D").Value = sh1.Range(Rout, "B").Value
                        .Cells(Rout + 1, "E").Value = sh1.Range(Rout, "G").Value
                        .Cells(Rout + 1, "F").Value = sh1.Range(Rout, "AA").Value
                        .Cells(Rout + 1, "G").Value = sh2.Range(Rout, "AA").Value
                    End With

                    Rout = Rout + 1
                Next sh
                wb.Close False
            End If
            FileName = Dir
        Loop
        MsgBox "処理終了"
    End Sub

（もこな２） 2021/11/14(日) 09:58

もこな２さま

＞ご回答ありがとうございます。

同じbookのシートが異なるところを見て、書き直してみました。
どこが、間違っているのでしょうか。

    Sub 修正２()
        Dim wb As Workbook
        Dim sh1,sh2 As Worksheet　←修正しました。
        Dim Rout As Long
        Dim FilePath As String 'パス＆ファイル名
        Dim FileName As String? 'ファイル名　取得

        FilePath = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
        FileName = Dir(ThisWorkbook.Path & "\*.xlsx")

        Rout = 7
        Do While FileName <> ""
            If FileName <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & FileName, False, True)
                Set sh1 = Worksheets("情報1") '修正
                Set sh2 = Worksheets("情報2") '修正

                For Each sh In wb.Worksheets   '修正

                    With ThisWorkbook.Worksheets("データ1")
                        .Cells(Rout + 1, "B").Value = sh1.Range(Rout, "A").Value
                        .Cells(Rout + 1, "C").Value = sh1.Range(Rout, "F").Value
                        .Cells(Rout + 1, "D").Value = sh1.Range(Rout, "B").Value
                        .Cells(Rout + 1, "E").Value = sh1.Range(Rout, "G").Value
                        .Cells(Rout + 1, "F").Value = sh1.Range(Rout, "AA").Value
                        .Cells(Rout + 1, "G").Value = sh2.Range(Rout, "AA").Value
                    End With
                    Rout = Rout + 1
                Next sh
                wb.Close False
            End If
            FileName = Dir
        Loop
        MsgBox "処理終了"
    End Sub

（P） 2021/11/14(日) 21:25

■１
＞どこが、間違っているのでしょうか。
間違っているというより直したほうが良いと思うところ。

１）

 Dim sh1,sh2 As Worksheet　←修正しました。

↑のような書き方をすると、sh1はVariant型を指定したことになります。
よって↓のように記述したほうがよいでしょう。

 Dim sh1 As Worksheet,sh2 As Worksheet

２）

 Set sh1 = Worksheets("情報1") '修正
 Set sh2 = Worksheets("情報2") '修正

↑は「wb」に属するシートなのでしょうから↓のようにしたほうが良いでしょう。

 Set sh1 = wb.Worksheets("情報1") '修正
 Set sh2 = wb.Worksheets("情報2") '修正

３）

 For Each sh In wb.Worksheets

↑のようにするなら↓のように「sh」は宣言したほうが良いでしょう（もともと宣言されていたのですから削るべきではなかったと思います）

 Dim sh As Worksheet

■２
繰り返しになりますが、修正が済んだなら【ステップ実行】して思う通りいってないところを探ってみてはどうでしょうか？

なお、偶然にも↓でも似たようなコードが提示されていますので参考にされるとよいでしょう。
[[20211114092753]]　『条件分岐の方法』（BPA）　

（もこな２） 2021/11/15(月) 01:24

もう１点気づきましたので追加で。

■３

   For Each sh In wb.Worksheets   '修正
         (省略)
   Next sh

↑はどういう想定で記述しているのですか？
よく見るとループ中に「sh」が一切出てきませんね。そもそもいらないのではありませんか？

（もこな２） 2021/11/15(月) 08:00

もこな２さま

ご回答ありがとうございます。
おっしゃるとおり、Next shは不要でした。

（P） 2021/11/15(月) 23:40

他の部分は大丈夫ですか？
「FilePath」を取得したものの使ってないとか、「Rout」をデータ元と出力先両方に使っているなど、本当にそれでよいのか気になる点がほかにもありますが・・・

再三になりますが【ステップ実行】してちゃんと自己検証されたほうが良いと思います。

（もこな２） 2021/11/16(火) 08:07

＞もこな２さま
【ステップ実行】は実施してますが、構文エラー表示で止まっていますが。、
理由不明のため、こちらで質疑させて頂いております。

＞「FilePath」を取得したものの使ってないとか、
＞「Rout」をデータ元と出力先両方に使っているなど

ご指摘頂いた内容を、考えて記載しました。

 Sub 修正3()
        Dim wb As Workbook
　　　　Dim sh As Worksheet
　　　　Dim sh1 As Worksheet,sh2 As Worksheet
        Dim Rout As Long
        Dim Rin As Long　←新規　定義

        Dim FilePath As String 'パス＆ファイル名
        Dim FileName As String 'ファイル名　取得

        FilePath = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
        FileName = Dir(FilePath & "\*.xlsx")←修正

        Rout = 7
        Rin = 8　　←新たに定義

        Do While FileName <> ""
            If FileName <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(FilePath & "\" & FileName, False, True)←修正

                Set sh1 = wb.Worksheets("情報1") 
                Set sh2 = wb.Worksheets("情報2")

                For Each sh In wb.Worksheets

                    With ThisWorkbook.Worksheets("データ1")
                        .Cells(Rin, "B").Value = sh1.Range(Rout, "A").Value　←修正
                        .Cells(Rin  "C").Value = sh1.Range(Rout, "F").Value
                        .Cells(Rin  "D").Value = sh1.Range(Rout, "B").Value
                        .Cells(Rin  "E").Value = sh1.Range(Rout, "G").Value
                        .Cells(Rin  "F").Value = sh1.Range(Rout, "AA").Value
                        .Cells(Rin  "G").Value = sh2.Range(Rout, "AA").Value

                    End With

                    Rout = Rout + 1
                    Rin= Rin + 1　←追記

                wb.Close False

            End If

            FileName = Dir
        Loop

        MsgBox "処理終了"

    End Sub
（P） 2021/11/16(火) 16:03

＞構文エラー表示で止まっています

「For Each sh In wb.Worksheets」に対する「Next」がない

「.Cells(Rin "C").Value = sh1.Range(Rout, "F").Value」　->　「.Cells(Rin, "C").Value =　・・」

（わからん） 2021/11/16(火) 16:16

失礼しました。

Sub 修正4()

        Dim wb As Workbook
　　　　Dim sh As Worksheet
　　　　Dim sh1 As Worksheet,sh2 As Worksheet
        Dim Rout As Long
        Dim Rin As Long　←新規　定義

        Dim FilePath As String 'パス＆ファイル名
        Dim FileName As String 'ファイル名　取得

        FilePath = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
        FileName = Dir(FilePath & "\*.xlsx")←修正

        Rout = 7
        Rin = 8　　←新たに定義

        Do While FileName <> ""
            If FileName <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(FilePath & "\" & FileName, False, True)←修正

                Set sh1 = wb.Worksheets("情報1") 
                Set sh2 = wb.Worksheets("情報2")

                For Each sh In wb.Worksheets

                    With ThisWorkbook.Worksheets("データ1")
                        .Cells(Rin, "B").Value = sh1.Range(Rout, "A").Value　←修正
                        .Cells(Rin,  "C").Value = sh1.Range(Rout, "F").Value
                        .Cells(Rin,  "D").Value = sh1.Range(Rout, "B").Value
                        .Cells(Rin,  "E").Value = sh1.Range(Rout, "G").Value
                        .Cells(Rin,  "F").Value = sh1.Range(Rout, "AA").Value
                        .Cells(Rin,  "G").Value = sh2.Range(Rout, "AA").Value

                    End With

                  Next

                    Rout = Rout + 1
                    Rin= Rin + 1　←追記

                wb.Close False

            End If

            FileName = Dir

        Loop

     MsgBox "処理終了"

    End Sub

（P） 2021/11/16(火) 18:13

Sub 転記_Click()

   Dim wb As Workbook
   Dim sh1,sh2 As Worksheet
   Dim Rout As Long
   Dim FilePath As String 
   Dim FileName As String

   FileName = Dir(ThisWorkbook.Path & "\*.xlsx")

    Rout = 7
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & FileName, False, True)

            For Each sh In wb.Worksheets 
                If Left(sh1.Range(Rout, "A"), 2) = 75 Then
                    With ThisWorkbook.Worksheets("データ2")

              .Cells(Rout+1, "B").Value = sh1.Range(Rout, "A").Value
              .Cells(Rout+1, "C").Value = sh1.Range(Rout, "F").Value
              .Cells(Rout+1, "D").Value = sh1.Range(Rout, "B").Value
              .Cells(Rout+1, "E").Value = sh1.Range(Rout, "G").Value
              .Cells(Rout+1, "F").Value = sh1.Range(Rout, "AA").Value
              .Cells(Rout+1, "G").Value = sh2.Range(Rout, "AA").Value
          End With

          Rout = Rout + 1

          If Left(sh1.Range(Rout, "A"), 2) = 72 Then
            With ThisWorkbook.Worksheets("データ3")
              .Cells(Rout+1, "B").Value = sh1.Range(Rout, "A").Value
              .Cells(Rout+1, "C").Value = sh1.Range(Rout, "F").Value
              .Cells(Rout+1, "D").Value = sh1.Range(Rout, "B").Value
              .Cells(Rout+1, "E").Value = sh1.Range(Rout, "G").Value
              .Cells(Rout+1, "F").Value = sh1.Range(Rout, "AA").Value
              .Cells(Rout+1, "G").Value = sh2.Range(Rout, "AA").Value

            End With

           Rout = Rout + 1

           Else
               With ThisWorkbook.Worksheets("データ1")

              .Cells(Rout+1, "B").Value = sh1.Range(Rout, "A").Value
              .Cells(Rout+1, "C").Value = sh1.Range(Rout, "F").Value
              .Cells(Rout+1, "D").Value = sh1.Range(Rout, "B").Value
              .Cells(Rout+1, "E").Value = sh1.Range(Rout, "G").Value
              .Cells(Rout+1, "F").Value = sh1.Range(Rout, "AA").Value
              .Cells(Rout+1, "G").Value = sh2.Range(Rout, "AA").Value

            End With

            Next Rout

         wb.Close False

     End If

     FileName = Dir

    Loop

End Sub
（P） 2021/11/16(火) 18:49

■番外
よくわかりませんが↓の方の分も聞いてあげようということですか？
[[20211114092753]]　『条件分岐の方法』（BPA）

同じ方であれば、別人を装っても何一つ良いことはないと思うので、事情を明らかにしてひとつのトピックにまとめたほうがよいでしょう。

（もこな２） 2021/11/16(火) 19:09

■４
＞おっしゃるとおり、Next shは不要でした。
言っていることと修正内容が合ってませんよ。

 Sub 修正4()
   For Each sh In wb.Worksheets

   Next
 End Sub

「■３」のコメントを再読してください。

（もこな２） 2021/11/16(火) 19:15

■５
↓だと【ファイル】のパスが取得されてしまいませんか？

 FilePath = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")

その場合、↓はおかしなことになりませんか？

 FileName = Dir(FilePath & "\*.xlsx")←修正

さらに、付随して↓もマズいことになりませんか？

 Set wb = Workbooks.Open(FilePath & "\" & FileName, False, True)←修正

再三再四指摘していますが、本当にステップ実行して想定どおりの流れになっているか確認していますか？

（もこな２） 2021/11/16(火) 19:31

＞もこな２さま
ありがとうございます。
ステップ実行は行っていますが、止まる理由がわからず
こちらに相談しています。

（P） 2021/11/17(水) 05:09

＞もこな２さま

 ありがとうございます。
「■３」 のコメントを再読してください。

繰り返し、転記作業を行うので必要だと考えています。
おかしいですか？

調べていますが、ピンとこないです。
（P） 2021/11/17(水) 05:16

 よく分かりませんが
sh1.Range
sh1はshではないのかな
Next Rout 
Routになっています
ステップ実行中に変数の値等を確認しましょう
（どん） 2021/11/17(水) 05:48

埒が明かないので・・・

    Sub 研究用()
        Dim wb As Workbook
        Dim フォルダパス As String
        Dim ファイル名 As String
        Dim 出力行 As Long, データ行 As Long

        Stop 'ブレークポイントの代わり

        '【フォルダ】を選択してもらう
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                フォルダパス = .SelectedItems(1)
            Else
                MsgBox "フォルダが選択されなかったので処理を中止します"
                Exit Sub
            End If
        End With

        '【フォルダ】の中にあるブックを探す
        ファイル名 = Dir(フォルダパス & "*.xls?")

        '
        Do Until ファイル名 = ""
            If ファイル名 <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(フォルダパス & "\" & ファイル名)

                '7行目から【データの数だけ繰り返す】
                For データ行 = 7 To wb.Worksheets("情報1").Cells(wb.Worksheets("情報1").Rows.Count, "A").End(xlUp).Row
                    ThisWorkbook.Worksheets("データ1").Cells(出力行, "B").Value = wb.Worksheets("情報1").Range(データ行, "A").Value
                    ThisWorkbook.Worksheets("データ1").Cells(出力行, "C").Value = wb.Worksheets("情報1").Range(データ行, "F").Value
                    ThisWorkbook.Worksheets("データ1").Cells(出力行, "D").Value = wb.Worksheets("情報1").Range(データ行, "B").Value
                    ThisWorkbook.Worksheets("データ1").Cells(出力行, "E").Value = wb.Worksheets("情報1").Range(データ行, "G").Value
                    ThisWorkbook.Worksheets("データ1").Cells(出力行, "F").Value = wb.Worksheets("情報1").Range(データ行, "AA").Value
                    ThisWorkbook.Worksheets("データ1").Cells(出力行, "G").Value = wb.Worksheets("情報2").Range(データ行, "AA").Value

                    '1セット出力し終わったら、出力行を１ずらす
                    出力行 = 出力行 + 1
                Next データ行

                wb.Close False
            End If

            '次のExcelブックを探す
            ファイル名 = Dir()
        Loop

        MsgBox "処理終了"
    End Sub

例えば↑のようになるとおもうので、

 For Each sh In wb.Worksheets
   shに関係しない処理
 End With

↑の処理はいらないというのが「■３」の指摘です。
さらに、そんな無駄ループより開いたブックの情報1なり、情報2シートのデータ数だけ繰り返す処理を考えないとダメしょう。
（wb.Worksheets.Count がデータ数と一致するという説明でもあれば別ですが）

さらに、[[20211114092753]]　でコメントしてますが、データ行はブックを開くたびにリセットしないとおかしなことになりますよね。

（もこな２） 2021/11/17(水) 07:40

↑の訂正

 For Each sh In wb.Worksheets
   shに関係しない処理
 Next sh

（もこな２） 2021/11/17(水) 08:27

もこな２さんの言う「ステップ実行をしろ」の意味を理解していますか？
「1行ずつ動かしてエラーが出るか出ないか確認しろ」ということではありませんよ。
普通に動かしてエラーで止まるマクロはステップ実行で1行ずつ動かしたって止まります。
マクロの動作中に自分が想定した動作になっているか(開かれるブックだったり、変数の値だったり)を
ローカルウィンドウなりイミディエイトウィンドウなりで確認しなさい、と言ってるんです。
（傘） 2021/11/17(水) 09:26

横から失礼します。
＞情報１シートから、A列、F列、B列、G列、AA列　
＞情報2シートからAA列のデータを読み取り、
とのことですが、
転記元の範囲（行範囲）が明確に示されていないように思います。
# 私が読み飛ばしているのかもしれませんが（なにせ文字数多いので）、
# 確認のため回答ください。

（γ） 2021/11/17(水) 09:39

傘さん

＞ローカルウィンドウなりイミディエイトウィンドウなりで確認しなさい、と言ってるんです。
そこから、どうするですか？
わからないので、こちらにお聞きしているのですが
（P） 2021/11/17(水) 10:11

 完全無視のようだが、せっかく書いたので提示しておきます。
 動作未確認ですので、そちらで確認してください。

 Sub 転記_Click()
     Dim wb As Workbook
     Dim sh1 As Worksheet
     Dim sh2 As Worksheet
     Dim ws As Worksheet
     Dim Rout As Long
     Dim FileName As String
     Dim k As Long

     FileName = Dir(ThisWorkbook.Path & "\*.xlsx")

     Do While FileName <> ""
         If FileName <> ThisWorkbook.Name Then
             Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & FileName, False, True)
             Set sh1 = wb.Worksheets("情報1")
             Set sh2 = wb.Worksheets("情報2")

             '転記先シート
             Select Case Left(sh1.Range(Rout, "A"), 2)
             Case Is = 75
                 Set ws = ThisWorkbook.Worksheets("データ2")
             Case Is = 72
                 Set ws = ThisWorkbook.Worksheets("データ3")
             Case Else
                 Set ws = ThisWorkbook.Worksheets("データ1")
             End Select

             '転記
             Rout = ws.Cells(Rows.Count, "B").End(xlUp).Row + 1  
             For k = 1 To 100  ' 対象となる行が指定されていないので修正のこと'■■■
                 With ws
                     .Cells(Rout, "B").Value = sh1.Range(k, "A").Value
                     .Cells(Rout, "C").Value = sh1.Range(k, "F").Value
                     .Cells(Rout, "D").Value = sh1.Range(k, "B").Value
                     .Cells(Rout, "E").Value = sh1.Range(k, "G").Value
                     .Cells(Rout, "F").Value = sh1.Range(k, "AA").Value
                     .Cells(Rout, "G").Value = sh2.Range(k, "AA").Value
                 End With
                 Rout = Rout + 1
             Next
             wb.Close False
         End If
         FileName = Dir
     Loop
 End Sub

（γ） 2021/11/17(水) 10:42

確認すれば、どこの動きが自分の想定と違うかわかるじゃありませんか。
そしたらそこを本当にやりたい動作に修正すればいいですよね。
どう修正したらいいかわからないなら関連語句で調べるか、「ここがこうなって欲しいのにこう動いてしまう」と質問すればいいですよね。
（傘） 2021/11/17(水) 10:49

＞γさま

失礼しました。
情報シート１は２行目から末端まで
情報シート２も２行目から末端までです。

＞傘さま
それでは、やりたいこととエラー内容をご質問すれば良いですね。
わかりました。
（P） 2021/11/17(水) 11:00

欲しい答えが得られなくて難儀されてますかね？

ちょっと、ちゃんと勉強したい方だと思われるので、遠回りかと思われるかと知れませんが、
質問を読んで気になったことを書いてみます。

まず、用語の意味の再確認（私も復習して、自分なりの言葉で説明してみます。）

プログラムとは：手順のこと
　　　　　　　　運動会のプログラム、卒業式のプログラム
　　　　　　　　やることの手順がかいてありますね。それのことです。

プロシージャとは：これもグーグル翻訳で翻訳してもらうと、「手順」と出てきました。
　　　　　　　　　IT入門サイト等では、「手続き」となっているようです。
　　　　　　　　　汎用的に再利用可能な手順（作業手順書）のまとまりをプロシージャと
　　　　　　　　　いうようです。

つまり、あなたがやろうとしていることは、期待する結果を得るために、
その作業の手順を書き、コンピューターにその手順を実行してもらおうとしているわけですね。

エクセルとは：表計算ソフト（アプリケーション）の一種。

ファイルとは：データの管理の単位の一つ。利用者からみて最小のデータのまとまり。

つまり、あなたが開きたいのは、ファイルであり、そのためにエクセルというアプリケーション
を使うということです。
ファイルをダブルクリック　→　ファイルに関連付けられたアプリケーションが起動
　　→ファイルが開いて、可視化される
という手順を踏んでいるわけです。
あなたが開くのは、エクセルを使って開くと可視化できるファイル（エクセルファイル）
であり、エクセルではないはずです。
ちなみに、開かれたエクセルファイルは、エクセルから見るとブック（Workbook）となります。

上記を踏まえ、あなたが最初にやることは、作業手順の作成です（日本語で）。

1）プログラム開始
2）ダイアログボックスを表示し、取り込みたいデータのあるファイルを選択（複数あり）し、
ファイルのパスを取得
3）選択したファイルのパスを順次開く
4）行番号で繰り返す（条件を満たすまで繰り返し）
5）情報1シートの指定の行番号の指定の列を自ブックの指定のシートの指定のセルへ転記
6）情報2シートの指定の行番号の指定の列を自ブックの指定のシートの指定のセルへ転記
7）次の行番号へ（5へ戻る）
8）開いたファイルを閉じる
9）次のファイルのパスへ（3へ戻る）
10）プログラム終わり

ざっくりこうなると思いますが、
これをエクセル君に伝わるよう、VBAに翻訳していく訳です。

'1）プログラム開始
Sub test()

    Dim vPath As Variant
    Dim p As Variant
    Dim wb As Workbook
    Dim ixRow As Long
    Dim ixTo As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    '2）ダイアログボックスを表示し、取り込みたいデータのあるファイルを選択（複数あり）し、
    'ファイルのパスを取得
    vPath = Application.GetOpenFilename(FileFilter:="Microsoft Excelブック,*.xls?", _
                                        MultiSelect:=True)
    '3）取得したファイル名を順次繰り返す
    For Each p In vPath

        '3-1）個々のパスのファイルを開く
        Set wb = Workbooks.Open(p)
        '3-2) 作業対象のシートの取得
        Set ws1 = wb.Worksheets("情報1")
        Set ws2 = wb.Worksheets("情報2")

        '4）行番号で繰り返す（条件を満たすまで繰り返し）
        For ixRow = 7 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            '4-1)転記先行番号作成
            ixTo = ixTo + 1

            '5）情報1シートの指定の行番号の指定の列を自ブックの指定のシートの指定のセルへ転記
            With ThisWorkbook.Worksheets("データ1").Cells(ixTo, "A")
                .Cells(1, "B").Value = ws1.Cells(ixRow, "A").Value
                .Cells(1, "C").Value = ws1.Cells(ixRow, "F").Value
                .Cells(1, "D").Value = ws1.Cells(ixRow, "B").Value
                .Cells(1, "E").Value = ws1.Cells(ixRow, "G").Value
                .Cells(1, "F").Value = ws1.Cells(ixRow, "AA").Value
                '6）情報2シートの指定の行番号の指定の列を自ブックの指定のシートの指定のセルへ転記
                .Cells(1, "G").Value = ws2.Cells(ixRow, "AA").Value
            End With

            '7）次の行番号へ（5へ戻る）
        Next
        '8）開いたファイルを閉じる
        wb.Close False
        '9）次のファイルのパスへ（3へ戻る）
    Next
    '10）プログラム終わり
End Sub

ここまで書いてみて、気づくのは、
「選択したファイルの」の要件と、
Dir関数を使ったファイルの検索とが関連がありませんね。

VBA Dir 関数＞＞
https://www.tipsfound.com/vba/05dir

エクセルVBAでダイアログボックスを表示させ複数ファイルを1度に開く方法＞＞
https://asatte.biz/openfile-multi/

その辺はどちらが正解なのでしょうか？

あと、ステップインの件ですが、
１行づつ、プログラムを実行しながら、シート上の状態を確認したり、
ローカルウィンドウでその時々の変数の中身が期待した値になっているか確認するとよいと思います。

あと、質問文には、
自分がしたいことあるいは期待している結果と、
現状の期待してない結果も併せて記述していただけるとより期待した答えが、
早く得られるを思います。
あと、シート上のイメージを書き込まれるとさらに回答者にとってわかりやすい質問になります。
教えてもらうのですから、その手間を惜しんではダメだと思います。

（まっつわん） 2021/11/17(水) 13:04

＞まっつわん
長文ありがとうございます。
（P） 2021/11/17(水) 14:30

■６
このトピックでいえば

 (1)改行がめちゃくちゃなコードを提示する
　　　【構文エラーが出てるため実行できない】

 (2)直したコードは構文エラーにならないが、おそらくその時点でステップ実行はしていない

 (3) For Each ～ Nextループが要らないとの指摘を誤解して「Next sh」だけ削る
　　　【For Eachの相方がないのでコンパイルエラーで実行できない】

 (4) 削った「Next sh」に変えて「Next」を追加する
　　　　 ↑★いまココ

なのでしょうから、途中で止まるというのなら何処でどのようなエラーが発生しているのか具体的に説明して相談されるとよいとおもいます。

■７
既に別の回答者さんからも指摘がありますが、例えば「修正4」をステップ実行をしてしたら

 アレレ、「FilePath」にファイルパスが入るぞ
 アレレ、「FileName」が最初から""になってしまうぞ
 ん？、開いたブックのシート数だけ同じ処理が繰り返されるぞ
 あれれぇ～、２番目のブックはスタートが７行目からにならないぞ

等々、自分で気づけたでしょう。

■８
「転記_Click」のほうは、 [[20211114092753]]　で指摘済ですが、　IF～End if]、「With～End With」、「For Each～Next」等々、きちんと相方が記述されているか、インデントを付けながら自己チェックされるとよいと思います。
ただし、それは、以下の理由からこのトピックの質問が解決してからされるべきでしょう。

 ・２つのトピックで同じ失敗をしている
 ・別人を装ってまで、別々に質問したい意図があったと思われる

■９
その他気になったところ
＞情報シート１は２行目から末端まで
【末端】とは何ですか？どのように調べますか？

[[20211114092753]]で別案をコメントしてますが、さらに別案でパワークエリを使うと解決できるかもしれません。
余力があり興味があれば研究してみるとよいかもしれません。
（私自身は、分からないので説明はできませんが・・）

（もこな２） 2021/11/18(木) 08:07

コメント返信：

[ 一覧(最新更新順) ]

[[20211114090213]] 『フォルダ内のエクセルを選択し、選択したエクセル』（P） ページの最後に飛ぶ

[[20211114090213]]　『フォルダ内のエクセルを選択し、選択したエクセル』（P）　ページの最後に飛ぶ