スキルアップ・問題解決なら、モーグにおまかせ！

お疲れさまです。
 
下記のExcel vba は、共有フォルダーにあるExcelファイルを別のExcelシートに
データを結合させ追記していくコードになります。
※ネツトにて見つけたコードになります。
 
ここで、確認ですが、データを取得しているファイル名も一覧の横に記載したい
のですが、可能でしょうか

例:
製品番号　製品名　発売月 　数量 取得ファイル名
I123456 　恐竜1 　2023/01 10　　S20230505.xlsx
I123457 　恐竜2 　2023/02 20　　S20230505.xlsx
I123458 　恐竜3 　2023/02 12　　S20230505.xlsx
S234567 　花2 　 2023/02 5 S20230506.xlsx
I345678 　虫2 　　2023/02 5 S20230506.xlsx
I232456 　虫1 　　2023/03 10 S20230607.xlsx
I232446 　虫3 　　2023/03 15 S20230607.xlsx
I232356 　果物1 　2023/03 5 S20230607.xlsx
 
下記のコードに何を加えれば良いのかを教えて下さい。
 
お忙しいとは思いますが宜しくお願い致します。
 
 
 
Dim path, fso, file, files
Dim Wb As Workbook
Dim LastRow_Wb As Long
 
    'マクロファイルを変数格納
    Set Wb = ActiveWorkbook
 
    '読み取るファイル格納先
    path = "\\共有\data"
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set files = fso.GetFolder(path).files
 
    '貼り付け開始位置
    LastRow_Wb = 1
 
    Application.ScreenUpdating = False
 
        'フォルダ内の全ファイルについて処理
        For Each file In files
 
            'エクセルファイルだったら処理を進める
            If fso.GetExtensionName(file) = "xlsx" Then
 
                'エクセルファイルを開く
                Workbooks.Open (file)
 
                'セルA1からD列の最終行までコピー
                Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 4)).Copy
 
                'データを値貼り付け
                Wb.ActiveSheet.Cells(LastRow_Wb, 1).PasteSpecial Paste:= _
                xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
                '最終行取得
                LastRow_Wb = Wb.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1
 
                '開いたエクセルファイルを保存せず閉じる
                Application.DisplayAlerts = False
                ActiveWindow.Close
                Application.DisplayAlerts = True
 
            End If
        Next file
 
    Application.ScreenUpdating = True
 
    MsgBox "完了"

お疲れさまです。
下記を追加して、ファイル名を取得できるようになりました。
あとは、リストの横にファイル名を追記するコードの作り方だけになります。
お忙しいとは思いますが宜しくお願い致します。
  
   Dim PathName As String, FileName As String 'ファイル名取得用
 
    Workbooks.Open (file)　の後に下記を追加して実行しました。
    FileName = Dir(file) 'ファイル名取得
    MsgBox FileName 'ファイル名表示

ブックを読み込んだあとに

    行数 = Cells(Rows.Count, 1).End(xlUp).Row

    貼り付け先のシート.Cells(LastRow_Wb, 5).Resize(行数, 1) = ファイル名

取得したファイル名を追記したいということですが、
 
※アイル名追記云々以前の疑問点
当該ブックの中に「複数のシートが存在する」ことは、ないのでしょうか？
若し、複数シートが存在するとした場合の問題点
複写元シートは、Activesheetになってしまいます。
結果として、エラーにならずに処理されるともありますが、
意図したデータが複写されているかの保証はない。
勿論、エラーになるかもしれません。
 

simpleさん
 
ありがとうございました。
私には、敷居が高いので、もう少しヒントを頂けないでしょうか
※各命令の内容がわかっていないため、何をどのようにしたら良い
のかを全く出てこないのです。
 
WinArrowさん
ご連絡をありがとうございました。
 
現状では、問題なく、複数のExcelファイルにあるデータを1つのExcel に
まとめられているので問題はないかと考えます。
 
お忙しいとは思いますが引き続き宜しくお願い致します。

私としては十分な回答をさしあげたと思っております。
提示されたコードを含め、コードを読む努力をしていただきたく思います。
それに不明点があるなら具体的にどこが不明か質問したほうが生産的です。
こちらの説明がなっていない、と言われているようで心外です。
すみませんが、他のかたからの回答をお待ちください。

引用:
※ネツトにて見つけたコードになります。

simple さんの引用:
私としては十分な回答をさしあげたと思っております。
提示されたコードを含め、コードを読む努力をしていただきたく思います。
それに不明点があるなら具体的にどこが不明か質問したほうが生産的です。
こちらの説明がなっていない、と言われているようで心外です。
すみませんが、他のかたからの回答をお待ちください。

WinArrow さんの引用:

引用:
※ネツトにて見つけたコードになります。

 
ネットでコードを探すのは、よいとしても、
自分でコードの内容を理解しないまま、他人に変更を依頼するのですか？
修正しないまま、動くおすれば、カンニングと一緒です。
 
まずは、コードの内容を理解するところから始めましょう。

VBA にこだわらないなら、こういう作業は PowerQuery をお勧めします。
 
あと、この作業は 1回だけなのでしょうか。
それとも、毎日なのでしょうか。
 
毎日なのであれば、なおさら　PowerQuery の方が早いですよ。
 
https://akmemo.info/folder-access-with-power-query/

※とりあえず質問者に言いたいこと書きます。
 

引用:
ブックを読み込んだあとに
    行数 = Cells(Rows.Count, 1).End(xlUp).Row
とデータの行数を調べておき、
データを張り付けたあとに、
    貼り付け先のシート.Cells(LastRow_Wb, 5).Resize(行数, 1) = ファイル名
のようにファイル名を書き込めばよいのではないですか？

引用:
当該ブックの中に「複数のシートが存在する」ことは、ないのでしょうか？
若し、複数シートが存在するとした場合の問題点
複写元シートは、Activesheetになってしまいます。
結果として、エラーにならずに処理されるともありますが、
意図したデータが複写されているかの保証はない。
勿論、エラーになるかもしれません。

引用:
simpleさんの回答では、いつでも良い人向けではないでしょうか
または、これからVBAを学びたい人向けですね
   
ただ、全員がそのような人ばかりでないため、決めつけるのはどうかと
考えます。業務で作っているから、早めに結果に結びつけたい方も少なく
ないはずです。

ご提示のコードでホントに例のような結果になりますか？
(当然、取得ファイル名は抜いての話ですが）
 
毎回、タイトル行も書き出しているような気がするんですが。
 

上の認識が正しい場合、2回目以降のタイトル行を書き出さない案
 
Sub test()
    Dim path, fso, file, files
    Dim Wb As Workbook
    Dim LastRow_Wb As Long
    Dim TargetWB As Workbook
    Dim RwCount As Long
     
    'マクロファイルを変数格納
    Set Wb = ThisWorkbook
     
    '読み取るファイル格納先
     path = "\\共有\data"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set files = fso.GetFolder(path).files
     
    '貼り付け開始位置
    LastRow_Wb = 1
    Application.ScreenUpdating = False
     
    'フォルダ内の全ファイルについて処理
    For Each file In files
         
        'エクセルファイルだったら処理を進める
        If fso.GetExtensionName(file) = "xlsx" Then
             
            'エクセルファイルを読み取り専用で開く
            Set TargetWB = Workbooks.Open(file, , True)
             
            'セルA1からD列の最終行までコピー(但し、2回目はA2からD列)
            With TargetWB.ActiveSheet
                RwCount = .Cells(.Rows.Count, 1).End(xlUp).Row
                .Range(.Cells(IIf(LastRow_Wb = 1, 1, 2), 1), .Cells(RwCount, 4)).Copy
                 
                'データを値貼り付け
                Wb.ActiveSheet.Cells(LastRow_Wb, 1).PasteSpecial Paste:= _
                xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Wb.ActiveSheet.Cells(IIf(LastRow_Wb = 1, 2, LastRow_Wb), 5).Resize(RwCount - 1) = TargetWB.Name
            End With
             
            '最終行取得
            LastRow_Wb = Wb.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1
             
            '開いた読み取り専用ファイルを保存せず閉じる
            TargetWB.Close False
             
        End If
    Next file
     
    Application.ScreenUpdating = True
     
    MsgBox "完了"
End Sub

taitaniさん、ご指摘やPowerQueryの件をありがとうございました。
私もPowerQueryのやり方を模索しておりました。
 
ただ、掲示板って、急ぎではないですが、修正のきっかけになると
思っての投稿なので、いいかげんな投稿以外はどうかなと思います。
 
半平太さん　ご投稿をありがとうございました。
投稿して頂いたコードを試してみたいと思います。
 
一旦PowerQueryの方向で検討したいのでクローズとさせて頂きます。
 
みなさまありがとうございました。