複数csvを横に追加していくマクロについて

複数のCSVを横に追加していくマクロを作る必要があり、
なんとか動きそうなコードを見つけました。

A列とB列を抜かしてC1セルから最終列と最終行（CSVによって最終列がバラバラです。
最終行は同じ数です。）を取得して
貼り付けることをしたいのですが、
こちらのコードだと、A1セルからの貼り付けとなっています。

VBA初心者過ぎて、色々調べたりセルの値を変えたりしてみましたが
うまくいきません。

どなたか教えていただけませんでしょうか。
よろしくお願いいたします。

Sub merge()
Dim Folder_path As String, buf As String, Target As Worksheet
Dim LastCol As Long, TargetR As Long, TargetC As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
'1行目クリア、2行目以降を削除
.Rows(1).ClearContents
.Rows("2:" & Rows.Count).Delete
'フォルダの場所
Folder_path = "D:\Sample\CSV\"
'ファイルを順番に開く
buf = Dir(Folder_path & "*.csv")
Do While buf <> ""
Workbooks.Open Folder_path & buf, ReadOnly:=True
'CSVシート名を変数に入れる
Set Target = Workbooks(buf).Sheets(Split(buf, ".")(0))
'mergeシートのA1基準での最終列
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'開いたシートのA1基準での最終行、最終列
TargetR = Target.Cells(Rows.Count, 1).End(xlUp).Row
TargetC = Target.Cells(1, Columns.Count).End(xlToLeft).Column
'値で転記
.Range(.Cells(1, LastCol + 1), .Cells(TargetR, LastCol + TargetC)).Value = _
Target.Range(Target.Cells(1, 1), Target.Cells(TargetR, TargetC)).Value
'次へ
Workbooks(buf).Close False
buf = Dir()
Loop
'空白のA列削除
.Range("A:A").Delete
Application.ScreenUpdating = True
MsgBox "END"
End With
End Sub

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2023/04/25 11:59

>例えば1番目のcsvは全ての列がコピーされる

>2番目以降が3列目～最終列までがコピーされる
>のように分けてコピーするようにはできるものでしょうか？？

最初からそのように提示していただければ、良かったかと。
以下のようにしてください。
Sub merge()
Dim Folder_path As String, buf As String, Target As Worksheet
Dim LastCol As Long, TargetR As Long, TargetC As Long
Dim ctr As Long: ctr = 0
Application.ScreenUpdating = False
With Sheets("Sheet1")
'1行目クリア、2行目以降を削除
.Rows(1).ClearContents
.Rows("2:" & Rows.Count).Delete
'フォルダの場所
Folder_path = "D:\Sample\CSV\"
'ファイルを順番に開く
buf = Dir(Folder_path & "*.csv")
Do While buf <> ""
ctr = ctr + 1
Workbooks.Open Folder_path & buf, ReadOnly:=True
'CSVシート名を変数に入れる
Set Target = Workbooks(buf).Sheets(Split(buf, ".")(0))
'mergeシートのA1基準での最終列
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'開いたシートのA1基準での最終行、最終列
TargetR = Target.Cells(Rows.Count, 1).End(xlUp).Row
TargetC = Target.Cells(1, Columns.Count).End(xlToLeft).Column
'値で転記
If ctr = 1 Then
.Range(.Cells(1, LastCol + 1), .Cells(TargetR, LastCol + TargetC)).Value = _
Target.Range(Target.Cells(1, 1), Target.Cells(TargetR, TargetC)).Value
Else
.Range(.Cells(1, LastCol + 1), .Cells(TargetR, LastCol + TargetC - 2)).Value = _
Target.Range(Target.Cells(1, 3), Target.Cells(TargetR, TargetC)).Value
End If
'次へ
Workbooks(buf).Close False
buf = Dir()
Loop
'空白のA列削除
.Range("A:A").Delete
Application.ScreenUpdating = True
MsgBox "END"
End With
End Sub

この回答へのお礼

そうですよね。すみません。
うちの自称VBA得意な社員が「それは難しいかも・・」と言っていたので
最初からあきらめていました(汗

今試してみたところ、まさに希望通りに動きました！！
これで大幅な業務圧縮がかないます。
本当に神です！！ありがとうございました。

お礼日時：2023/04/25 13:15

No.1 回答者： tatsumaru77 回答日時： 2023/04/25 10:00

値で転記の箇所を、以下のようにしてください。

'値で転記
.Range(.Cells(1, LastCol + 1), .Cells(TargetR, LastCol + TargetC - 2)).Value = _
Target.Range(Target.Cells(1, 3), Target.Cells(TargetR, TargetC)).Value

この回答へのお礼

素早いご回答ありがとうございます！
早速試してみましたが、
2つ目以降のcsvは3列目から最終列までを順番にコピーしてくれたのですが、
なぜか1つ目のcsvは3列目～最終列かー2列の真ん中だけが
コピーされる形でした。

例えば1番目のcsvは全ての列がコピーされる
2番目以降が3列目～最終列までがコピーされる

のように分けてコピーするようにはできるものでしょうか？？
まったくのド素人で申し訳ございません。
VBAの知見をお貸しいただけますと幸いです。

お礼日時：2023/04/25 11:32