【VBA】フォルダ内の複数ブックのデータとブック名の転記をしたい

Question

フォルダ内の複数ブックのデータとブック名を転記する

フォルダの中に複数のExcelファイル(ブック)が入っており、
それら全てのブックデータの転記を一括して行うマクロを現在使用しています。(後述)

＜現在の利用状況＞
・フォルダの中に複数のExcelファイル(ブック)が入っている。ファイルにつきシートは1つ（ひな形は同じ）
・ファイルを確認するまでデータが何行入っているか分からない
・貼り付ける際はシートの上部は意図的に消している

＜改善希望＞
・どのファイルから貼り付けたか分かるように、A列にファイル名を追記したい(どの行にも)
・できれば先頭の3文字のみ

VBA勉強中の初心者ですが、なるべく早く実装しないといけないので、困っています。。。。
ご教示頂けます様お願いいたします。

発生している問題・エラーメッセージ

ファイル名を転記するコードで以下のエラーが出てしまいます。
(該当のコードをコメントアウトすると＜改善希望＞以外の動作は最後まで行えます)

実行時エラー1004
Rangeメソッドは失敗しました:_Worksheetオブジェクト

該当のソースコード

Sub データ集計()

    '集計シートを変数に格納
    Dim ws As Worksheet
    Set ws = ActiveSheet 

    '集計シートを全て削除しておく
    ws.Cells.Clear
    
    '集計シートの最終行を取得しておく
    Dim LastRow As Long 'Longは整数を入れる
    LastRow = ws.Cells(Rows.Count, 5).End(xlUp).Row 
            
            
    'メッセージ
    MsgBox "このブックと同じフォルダにあるブックを全て統合します"
            
            
'---ファイルを開く前に、場所とファイル名の一覧を取得しておく
    
    'このブックの保存されているフォルダのパス（番地;ディレクトリ）を変数に取得
    Dim thisPath As String 
    thisPath = ThisWorkbook.Path
        
    
    'ディレクトリにあるExcelのファイル名を取得
    Dim fileName As String
    fileName = Dir(thisPath & "\" & "*.xlsx")
    
        
    '画面のちらつきを防止する
    Application.ScreenUpdating = False
    
    
    
'---ループで順番にファイルを開いてデータを取り込む
        
    'ループカウンタ変数
    Dim i As Long
    
    
    'ファイル名が無くなるまで繰り返す
    Do While fileName <> ""
        
        '開くワークブックを変数に代入
        Dim bufBook As Workbook
        Set bufBook = Workbooks.Open(thisPath & "\" & fileName) 
        
  
        '開いたブックの第1シートの全データ --> 集計シートの最終行
        bufBook.Worksheets(1).Range("B14").CurrentRegion.Copy Destination:=ws.Range("B" & LastRow)
        

       '現時点の最終行を取得
        Dim NEWLastRow As Long
        NEWLastRow = ws.Cells(Rows.Count, 5).End(xlUp).Row
        
       '開いたブックの名前をA列に追加
        ws.Range(Cells(LastRow, 1), Cells(NEWLastRow, 1)) = Left(fileName, 3)
        
       
        Dim LastRowSecond As Long
        LastRowSecond = LastRow + 13
        
        '最初のループ以外では、タイトル行を削除しておく
        If i > 0 Then
           ws.Rows(LastRow & ":" & LastRowSecond).Delete
        End If
        
        '開いたブックを閉じる
        bufBook.Close SaveChanges:=False   
                
        '集計シートの最終行を再取得しておく
        LastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row + 1
       
        
        'まだ返していないファイル名を順に返し次のファイル名が取り出される。
        fileName = Dir()
        
        i = i + 1

    Loop
    
    '画面のちらつき防止措置を終了
    Application.ScreenUpdating = True

End Sub

試したこと

以下は試しましたが、
各データの最終行にだけファイル名がつくようになりました。

'現時点の最終行を取得
'Dim NEWLastRow As Long
'NEWLastRow = ws.Cells(Rows.Count, 5).End(xlUp).Row

    '開いたブックの名前をA列に追加
    'ws.Range("A" & NEWLastRow) = Left(fileName, 3)
    
    

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Answer 1

これでどうでしょうか。

ws.Range(ws.Cells(LastRow, 1), ws.Cells(NEWLastRow, 1)) = Left(fileName, 3)

Comments

[ohagimaru]

おかげさまで解決できました！
素早い回答本当にありがとうございます。
ws.の付け忘れは盲点でした。