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

質問

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

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

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

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

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub データ集計()

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

'集計シートの最終行を取得
Dim LastRow As 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")

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 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

End Sub

回答No.2

kkkkkm · ベストアンサー

> A1に1ファイル目のファイル名が入ったのみで
> 終了してしまいました。。。。

よく見たら、閉じる前に削除があるみたいですね

他のデータはコピーされてるとしたら

> '開いたブックを閉じる
> bufBook.Close SaveChanges:=False

閉じる前に
ws.Range("A" & LastRow)=Left(fileName,3)
としておくとか。LastRowは適当に合わせてください。

お礼

いただいた回答を元に、
bufBook.Worksheets(1).Range("B14").CurrentRegion.Copy Destination:=ws.Range("B" & LastRow)
の後、
現在の最終行(＝NEWLastRow)を取得したあとに
ws.Range(ws.Cells(LastRow, 1), ws.Cells(NEWLastRow, 1)) = Left(fileName, 3)
を追記するとうまくいきました。

ありがとうございました
ありがとうございました。

回答No.1

kkkkkm

bufBook.Worksheets(1).Range("B14").CurrentRegion.Copy Destination:=ws.Range("B" & LastRow)

のあとに

ws.Range("A" & LastRow)=Left(fileName,3)

でいけそうな気がします。

補足

アドバイスいただいた通り、

ws.Range("A" & LastRow) = Left(fileName, 3)

で試してみたのですが、
A1に1ファイル目のファイル名が入ったのみで
終了してしまいました。。。。