【マクロ】【画像あり】４つのファイルデータを別ブックの４つのシートへそれぞれコピーしたい

【やりいた事】下記画像をご覧ください

◆◆◆４つのCSVシートのデータを、別ブックの４つのシートへそれぞれコピーしたいです◆◆◆
※CSVはexcelブックに置き換えて考えて頂いてもOKです。同じです

４つのCSVシートを別ブックの１つのシートへコピーするコードは出来ました
以下の参考コード❶をご覧ください

しかし、やりたい事は、４つのファイルデータを１つのシートではなく、４つのシートへ
コピーする方法です


コピーの方法は、以下です
ws.Range("A1").CurrentRegion.Copy

貼付けは、４つのシートのそれぞれの　A1セル　にてOKです

最後に、参考コード❷は、シートを１番目から４番目まで順番に移動するコードです
移動するたびに、作業のコードを入れる事も出来ます

ここに、４つのファイルデータの内の１つをコピペするコードを入れてもうまく
いくと思います


コードならびにアドバイスのご教授お願いします




【ファイルパス】コピー先
"C:\Users\user\Documents\web\最新配列.xlsm"
※４つのファイルのデータをコピーしたいファイル
※シート名⇒Sheet1、Sheet2、Sheet3、Sheet4、


【ファイルパス】※４つのファイル

"C:\Users\user\Documents\web\ダウンロード場所\a_20250529123939.csv"
※シートは１つしかない。名前は不規則

"C:\Users\user\Documents\web\ダウンロード場所\a_20250529123940.csv"
※シートは１つしかない。名前は不規則

"C:\Users\user\Documents\web\ダウンロード場所\a_20250529123941.csv"
※シートは１つしかない。名前は不規則

"C:\Users\user\Documents\web\ダウンロード場所\a_20250529123942.csv"
※シートは１つしかない。名前は不規則



【参考コード❶】4つのファイルデータを1つのファイルへ集約
Sub 順番｡4つのファイルデータを1つのファイルへ集約()

Dim folder_path As String
Dim fso As FileSystemObject
Dim Folder As Folder
Dim File As File
Dim wb As Workbook



' フォルダのパスを指定
folder_path = "C:\Users\user\Documents\web\ダウンロード場所\"

' FileSystemObjectを作成
Set fso = New FileSystemObject

Set Folder = fso.GetFolder(folder_path)

' フォルダ内のファイルを順次処理

For Each File In Folder.Files

If File.Name Like "*.csv" Then

' ファイルを開く
Set wb = Workbooks.Open(File.Path)

Set ws = wb.Worksheets(1)




' 1つのシートに４つのファイルデータをコピー貼り付け

lastrow = ThisWorkbook.Worksheets("集約").Cells(Rows.Count, 1).End(xlUp).Row

ws.Range("A1").CurrentRegion.Copy

ThisWorkbook.Worksheets("集約").Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False


wb.Close SaveChanges:=True


End If


Next File


End Sub



【参考コード❷】
４つのシートに順番にバトンタッチし、作業をする。作業は、４つのフアィルデータをそれぞれコピペしたい

Sub sheetarrayの配列()

Dim allsheet(3) As Variant

allsheet(0) = "Sheet1"

allsheet(1) = "Sheet2"

allsheet(2) = "Sheet3"

allsheet(3) = "Sheet4"


Dim i As Long
Dim ws As Worksheet


For i = 0 To 3
Set ws = ThisWorkbook.Worksheets(allsheet(i))
MsgBox allsheet(i)


●●●●●●●●●●●●●●●●●●●●●●●●●●

ここに４つのファイルのデータをコピーするデータを
開き、コピペするコードを貼り付けるコードを入れたい

●●●●●●●●●●●●●●●●●●●●●●●●●●

Next
End Sub

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2025/05/31 23:10

Sheet1～Sheet4ではなく、シート①～シート④にコピーするようにしました。

Const Folder_path As String = "D:\goo\data\ダウンロード場所"
は、あなたの環境に合わせてください。
CSVファイルが５個以上の場合は、エラーになります。

>データは更新日時順にて貼りつきました
>そのようなルールにて貼りつく物なのでしょうか？
回答：dir関数を実行すると、ファイル名の昇順にファイル名を取得するので、そのようになります。ファイル名がダウンロード順になっているので、
更新日時順にコピーされます。
--------------------------------------------------------
Sub シートコピー()
Const Folder_path As String = "D:\goo\data\ダウンロード場所"
Dim fname As String
Dim wb As Workbook
Dim rg As Range
Dim sno As Long: sno = 0
Dim sname As String
Dim name_tbl As Variant
name_tbl = Array("シート①", "シート②", "シート③", "シート④")
fname = Dir(Folder_path & "\*.csv")
Do While fname <> ""
Set wb = Workbooks.Open(Folder_path & "\" & fname)
Set rg = wb.Worksheets(1).Cells(1, 1).SpecialCells(xlLastCell)
sname = name_tbl(sno)
wb.Worksheets(1).Cells(1, 1).Resize(rg.Row, rg.Column).Copy Destination:=ThisWorkbook.Worksheets(sname).Cells(1, 1).Resize(rg.Row, rg.Column)
wb.Close
sno = sno + 1
fname = Dir()
Loop
End Sub

この回答へのお礼

tatsumaru77様
全て、うまく出来ました。大変、大変、ありがとうございます
１回、時分の求めていた物は全て実装できました

本コードをさらにブラッシュアップさせて頂く為
本サイト新規から補足の質問させて頂きます

お時間ありましたら、宜しくお願いします

【参考ツール】
コードは文字数オーバーにて掲載不可の為、新規質問へのせます

お礼日時：2025/06/01 10:03

No.1 回答者： tatsumaru77 回答日時： 2025/05/31 09:49

以下のようにしてください。

使用時の注意事項
１．CSVファイルの場所
Const Folder_path As String = "D:\goo\data\ダウンロード場所"
は、あなたの環境にあわせて適切に設定してください。
２．コピー先のシート名は
"Sheet" + 連番（1～） になります。
csvファイルが5個の時は、Sheet1～Sheet5へコピーします。
csvファイルが1個の時は、Sheet1のみへコピーします。
　
--------------------------------------------------
Option Explicit

Sub シートコピー()
Const Folder_path As String = "D:\goo\data\ダウンロード場所"
Dim fname As String
Dim wb As Workbook
Dim rg As Range
Dim sno As Long: sno = 1
Dim sname As String
fname = Dir(Folder_path & "\*.csv")
Do While fname <> ""
Set wb = Workbooks.Open(Folder_path & "\" & fname)
Set rg = wb.Worksheets(1).Cells(1, 1).SpecialCells(xlLastCell)
sname = "Sheet" & sno
wb.Worksheets(1).Cells(1, 1).Resize(rg.Row, rg.Column).Copy Destination:=ThisWorkbook.Worksheets(sname).Cells(1, 1).Resize(rg.Row, rg.Column)
wb.Close
sno = sno + 1
fname = Dir()
Loop
End Sub

この回答へのお礼

tatsumaru77　様

コードうまく動きました
大変、大変、ありがとうございます

補足質問させていただきます

【質問１】
大変恐縮ですがシート名は以下のとおり実際固定の名前です
今回のご教授のコードと同じ効果がある
良いコードはありますか？
コードorアドバイスお願いします

【シート名】
集約シートA
集約シートB
シート①
シート②
シート③
シート④

【条件】
CSVデータは１個～４個となります。名前は毎回違います


【質問2】
データは更新日時順にて貼りつきました
そのようなルールにて貼りつく物なのでしょうか？
なお、更新日順に、シート①⇒シート②・・・と
貼りつき希望だった為、今回の良かったです

CSVデータはWEBからダウンロードします
DLした時間順にて貼り付けたいという意味です



【参考コード。少し変更しました】
Sub シートコピー()

'CSVファイルが格納してあるパス
Const Folder_path As String = "C:\Users\2020\OneDrive\マクロ\ソクコム\ダウンロード場所"

Dim fname As String

Dim wb As Workbook

Dim rg As Range

Dim sno As Long: sno = 1

Dim sname As String

'CSVファイルのパス
fname = Dir(Folder_path & "\*.csv")

'ファイルが入っているフォルダが空白になるまでずっと
Do While fname <> ""

'CSVファイルのパス。１つ目のCSVを開く
Set wb = Workbooks.Open(Folder_path & "\" & fname)

'CSVファイルの全選択と思われる

'シートの名前１から４
sname = "Sheet" & sno

wb.Worksheets(1).Range("A1").CurrentRegion.Copy
ThisWorkbook.Worksheets(sname).Cells(1, 1).PasteSpecial Paste:=xlPasteValues

wb.Close
sno = sno + 1
fname = Dir()
Loop
End Sub

お礼日時：2025/05/31 22:06