VBA シート名をコピー＆ペースト

質問

いつもお世話になります。
A、Bのファイルのシートからデーターをコピーして、別ファイルsheet2にC列以降貼り付けします。
そのデーターの数だけ、そのシート名（担当者名）をB列に貼り付けしたいのですが、1行目だけしか貼り付けできません。
コードを教えていただけないでしょうか？
よろしくお願いいたします。
Sub コピー()
Dim ws2 As Worksheet
Dim FP As Variant
Dim i As Long, j As Long, t As Long, n As Long, m As Long
Dim wb As Workbook
'選択したフォルダのパス名を取得
FP = Application.GetOpenFilename("Excel ファイル (*.xlsm),*.xlsm", MultiSelect:=True)

For i = LBound(FP) To UBound(FP)
Set ws2 = ThisWorkbook.Worksheets("Sheet2") '書きだすシート
Set wb = Workbooks.Open(FP(i)) 'データーファイル

t = ws2.Range("D" & Rows.Count).End(xlUp).Row
j = wb.Worksheets(1).Range("D" & Rows.Count).End(xlUp).Row
n = ws2.Range("B" & Rows.Count).End(xlUp).Row

wb.Worksheets(1).Activate
wb.Worksheets(1).Range(Cells(7, 2), Cells(j, 35)).Copy
ws2.Activate
ws2.Range("C" & t + 1).PasteSpecial Paste:=xlValues

ws2.Range(Cells(n + 1, 2), Cells(t, 2)).Value = wb.Worksheets(1).Name　←この列
Next i

End Sub

A、Bのファイルデーター
　　　A　　　B 　　　C　　　D　　　　　E
1　　NO　　業種 　物件名 　目標種別 区分
2　　　1 あ　　　　あい　　かえ　　　　A
3　　　2 い　　　　いい　　きえ　　　　A
4　　　3 う　　　　うい　　くえ　　　　A
5　　　4 え　　　　えい　　けえ　　　　A
6　　　5 お　　　　おい　　こえ　　　　A

コピーするファイルのシート（最終出来上がり希望）
　　　A　　　B 　　　C　　　D　　　　　E　　　　D
1　　NO　　担当者　業種 　物件名 　目標種別 区分
2　　　1 　　 鈴木　 あ　　　　あい　　かえ　　　　A
3　　　2 　　 鈴木　 い　　　　いい　　きえ　　　　A
4　　　3 　　 鈴木　 う　　　　うい　　くえ　　　　A
5　　　4 　　 鈴木　 え　　　　えい　　けえ　　　　A
6　　　5 　　 鈴木　 お　　　　おい　　こえ　　　　A
2　　　1 　　 田中　 あ　　　　あい　　かえ　　　　A
3　　　2 　　 田中　 い　　　　いい　　きえ　　　　A
4　　　3 　　 田中　 う　　　　うい　　くえ　　　　A
5　　　4 　　 田中　 え　　　　えい　　けえ　　　　A
6　　　5 　　 田中　 お　　　　おい　　こえ　　　　A

コピーするファイルのシート（現在）
　　　A　　　B 　　　C　　　D　　　　　E　　　　D
1　　NO　　担当者　業種 　物件名 　目標種別 区分
2　　　1 　　 鈴木　 あ　　　　あい　　かえ　　　　A
3　　　2 　　 田中　 い　　　　いい　　きえ　　　　A
4　　　3 　　 田中　 う　　　　うい　　くえ　　　　A
5　　　4 　　 田中　 え　　　　えい　　けえ　　　　A
6　　　5 　　 田中　 お　　　　おい　　こえ　　　　A
2　　　1 　　 田中　 あ　　　　あい　　かえ　　　　A
3　　　2 　　 　　　 い　　　　いい　　きえ　　　　A
4　　　3 　　 　　　 う　　　　うい　　くえ　　　　A
5　　　4 　　 　　　 え　　　　えい　　けえ　　　　A
6　　　5 　　 　　　 お　　　　おい　　こえ　　　　A

回答No.3

ushi2015 · ベストアンサー

こんにちは、また間違えてしまいました。
.Offset(, -1).Resize(j - 6, 1).Value = ws.Name '←この列
に変更してみて下さい。

お礼

希望通りのものができました。
ありがとうございました。
これからもよろしくお願いします。

回答No.2

ushi2015

こんにちは
投稿する時にちょっと修正したのですが漏れが有りました。
.Offset(, -1).Value = ws.Name '←この列
を
.Offset(, -1).Resize(j - 6, 34).Value = ws.Name '←この列
に変更してみて下さい。

回答No.1

ushi2015

こんにちは
t = ws2.Range("D" & Rows.Count).End(xlUp).Row
n= ws2.Range("B" & Rows.Count).End(xlUp).Row
って、同じ数値ですよね？
Sub コピー()
　　Dim ws2 As Worksheet
　　Dim FP As Variant
　　Dim i As Long, j As Long, t As Long
　　Dim wb As Workbook
　　Dim ws As Worksheet
　　'選択したフォルダのパス名を取得
　　FP = Application.GetOpenFilename("Excel ファイル (*.xlsm),*.xlsm", MultiSelect:=True)

　　For i = LBound(FP) To UBound(FP)
　　　　Set ws2 = ThisWorkbook.Worksheets("Sheet2") '書きだすシート
　　　　Set wb = Workbooks.Open(FP(i)) 'データーファイル
　　　　Set ws = wb.Worksheets(1)

　　　　t = ws2.Range("D" & Rows.Count).End(xlUp).Row
　　　　j = wb.Worksheets(1).Range("D" & Rows.Count).End(xlUp).Row

　　　　With ws2.Range("C" & t + 1)
　　　　　　.Resize(j - 6, 34).Value _
　　　　　　　　= ws.Range(ws.Cells(7, 2), ws.Cells(j, 35)).Value
　　　　　　.Offset(, -1).Value = ws.Name '←この列
　　　　End With
　　Next i
End Sub

補足

ありがとうございます。
ｔとｎは、データーを貼り付けた後は、違うと思っていました。

たとえば、先にB７からE１００までコピーして
C7に貼り付けると、ｔ=１００になるのだと思っていました。
ｎ＝6
でも、この考え方が間違っていて、B列の担当者がうまく貼り付かなかったのだと思います。

教えていただいたコードを実行してみると、担当者の1セル（B7)と（B101）にだけ名前が貼りつきました。
上記の例でいうと、B7からB100まで担当者（Aファイルのシート名）が入るようにしたいのです。
（B101からは、Bファイルのシート名がデーターの数だけ）
再度おしえていただけないでしょうか？