【マクロ】【画像あり】❶ブックから別ブックへデータ貼付❷分岐 シート①にデータありシート②へ貼付の件

【やりたい事】
ブックAからブックBへデータを貼付したい
貼付先ブックBのシートは４つある(シート①　シート②　シート③　シート④)
⇒シート①にデータがあった場合、シート②へ貼付をしたい

【手順】
1a_20250529123939.xlsx　を開く。下記参考コードあり
2シート①に貼り付けようとする。下記参考コードあり
3シート①の最終行が２行目まである場合⇒次のシート②へ貼付けする
※シート②は最終行が２行目より小さい。貼り付け可能
※シート①から④は、次のいずれかどっち
⇒パターン１：データが２行目以上ある。パターン２：データが１つもない。空シート
4シート②へ貼り付け
5a_20250529123939.xlsxを閉じる


【ファイルパス】

貼付元エクセル。シート１つだけ。シート名不規則
C:\Users\user\Documents\ツール\ダウンロード場所\ファイル名変更場所\a_20250529123939.xlsx
ファイル名⇒a_20250529123939.xlsx

貼付先エクセル
C:\Users\user\Documents\ツール\ツール.xlsm
貼付先シート４つ⇒　シート①　シート②　シート③　シート④
ファイル名⇒ツール.xlsm


マクロが保存されているファイル
C:\Users\user\Documents\ツール\コントロール.xlsm
ファイル名⇒コントロール.xlsm


【参考コード】ファイルを開き、シート①へ貼り付けするコード
Sub フォルダ内のファイル1つ開く()

Dim folder_path As String ' インプットファイルのフォルダパス
Dim file_name As String ' 現在処理中のファイル名
Dim file_path As String ' 現在処理中のファイルのフルパス
Dim file_count As Long ' フォルダ内のファイル数
Dim src_wb As Workbook ' 処理対象のブックオブジェクト


' フォルダパスの設定
folder_path = "C:\Users\user\Documents\ツール\ダウンロード場所\ファイル名変更場所\"


' フォルダ内のファイル確認
file_count = 0
file_name = Dir(folder_path & "*.csv") ' フォルダ内のExcelファイルを取得
Do While file_name <> ""
file_count = file_count + 1 ' ファイル数をカウント
file_path = folder_path & file_name ' ファイルパスを生成
file_name = Dir() ' 次のファイルを取得
Loop


' ファイル数が1でない場合は、プロセスを終了
If file_count <> 1 Then
MsgBox "CSVファイルが2個以上あります" & vbCrLf & _
"CSVファイル: " & file_count, vbExclamation
Exit Sub '条件を満たさない場合、これ以上処理を続けないために終了
End If


' 対象ファイルを開く
Set src_wb = Workbooks.Open(file_path)


' 貼り付け先のブックを開く
Dim wb1 As Workbook

filepath = "C:\Users\user\Documents\ツール\ツール.xlsm"

Set wb1 = Workbooks.Open(filepath)

Dim allsheet As Variant

' シート４つを配列変数に入れる
allsheet = Array("シート①", "シート②", "シート③", "シート④")

src_wb.Worksheets(1).Cells(1, 1).CurrentRegion.Copy

wb1.Worksheets(allsheet(0)).Cells(1, 1).PasteSpecial Paste:=xlPasteValues

End Sub

No.3 回答者： tatsumaru77 回答日時： 2025/06/05 06:41

>Q1.コードの中でフォルダパス１つファイルパス１つの合計２

つですよね？
回答：
① folder_path = "C:\Users\user\Documents\ツール\ダウンロード場所\ファイル名変更場所\"
② filepath = "C:\Users\user\Documents\ツール\ツール.xlsm"
のことでしょうか。そうでしたら２つです。

>Q2.本コードは、データを転記したいファイルは１つだけ
フォルダに設置して動く仕組みですよね？⇒動きました

回答：はい、そうです。

No.2 回答者： tatsumaru77 回答日時： 2025/06/03 11:30

No1です。

以下の行ですが
①folder_path = "C:\Users\user\Documents\ツール\ダウンロード場所\ファイル名変更場所\"
②folder_path = "D:\goo\data\ダウンロード場所\"

③filepath = "C:\Users\user\Documents\ツール\ツール.xlsm"
④filepath = "D:\goo\excel\ツール.xlsx"


③、④の行を削除してください。
こちらの環境ように修正した行を削除し忘れてました。

この回答へのお礼

tatsumaru77 様
大変、有用なコードを正確にかつ素早く、ご指南頂きまして
ありがとうございます

うまく、動きました。思い通りのコードなりました

ただ、まだ、私が全て、理解していない所だけでございます

なお、以下質問です。お手すきな時に教えて下さい

【質問】
Q1.コードの中でフォルダパス１つファイルパス１つの合計２
つですよね？

下記のとおりフォルダパスとファイルパスを設定したところ
うまく、動きました

Q2.本コードは、データを転記したいファイルは１つだけ
フォルダに設置して動く仕組みですよね？⇒動きました


' 開きたいファイルが保管されているフォルダパスの設定
ファイル保管数は１つ
folder_path = "C:\Users\2020\OneDrive\マクロ\ツール\ダウンロード場所\ファイル名変更場所\"

'貼付先ツールのファイルパス
filepath = "C:\Users\2020\OneDrive\マクロ\ツール\ツール.xlsm"

なお、別件まだ、内容確認中です
理解できましたら、質問させて頂きたいと思います

お礼日時：2025/06/04 22:10

No.1 回答者： tatsumaru77 回答日時： 2025/06/03 10:18

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

Option Explicit
Sub フォルダ内のファイル1つコピー()

Dim folder_path As String ' インプットファイルのフォルダパス
Dim file_name As String ' 現在処理中のファイル名
Dim file_path As String ' 現在処理中のファイルのフルパス
Dim file_count As Long ' フォルダ内のファイル数
Dim src_wb As Workbook ' 処理対象のブックオブジェクト


' フォルダパスの設定
folder_path = "C:\Users\user\Documents\ツール\ダウンロード場所\ファイル名変更場所\"
folder_path = "D:\goo\data\ダウンロード場所\"


' フォルダ内のファイル確認
file_count = 0
file_name = Dir(folder_path & "*.csv") ' フォルダ内のExcelファイルを取得
Do While file_name <> ""
file_count = file_count + 1 ' ファイル数をカウント
file_path = folder_path & file_name ' ファイルパスを生成
file_name = Dir() ' 次のファイルを取得
Loop


' ファイル数が1でない場合は、プロセスを終了
If file_count <> 1 Then
MsgBox "CSVファイルが2個以上あります" & vbCrLf & _
"CSVファイル: " & file_count, vbExclamation
Exit Sub '条件を満たさない場合、これ以上処理を続けないために終了
End If


' 対象ファイルを開く
Set src_wb = Workbooks.Open(file_path)


' 貼り付け先のブックを開く
Dim wb1 As Workbook
Dim filepath As String
filepath = "C:\Users\user\Documents\ツール\ツール.xlsm"
filepath = "D:\goo\excel\ツール.xlsx"

Set wb1 = Workbooks.Open(filepath)

Dim allsheet As Variant

' シート４つを配列変数に入れる
allsheet = Array("シート①", "シート②", "シート③", "シート④")
'空きシートを検索する
Dim sname As String
sname = GetEmptySheet(wb1, allsheet)
If sname = "" Then
MsgBox ("空きシート無し")
Exit Sub
End If
src_wb.Worksheets(1).Cells(1, 1).CurrentRegion.Copy

wb1.Worksheets(sname).Cells(1, 1).PasteSpecial Paste:=xlPasteValues
MsgBox (sname & "へコピーしました")
End Sub
'空きシート名取得関数
'戻り値：空きシートのシート名(""の場合空きシート無し)
Private Function GetEmptySheet(wb1 As Workbook, allsheet As Variant) As String
Dim i As Long
Dim sname As String
Dim lastRow As Long
For i = 0 To UBound(allsheet)
sname = allsheet(i)
lastRow = wb1.Worksheets(sname).Cells(Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then
GetEmptySheet = sname
Exit Function
End If
Next
GetEmptySheet = ""
End Function