VBAで、フォルダ内にある複数のエクセルブックに、別のブックの1シートをコピーしたい

VAB初心者で恐縮なのですが、お願いします。

手作業でいうと、
Aというファイルの中に、100個くらいのエクセルファイルがあり
そのファイルを一つ一つ開いて、別のブックの1シートを
一つ一つ開いたファイルの所定のシートに
形式を選択して貼り付けをしなくてはなりません。

100個のファイル名は変更不可です。

どのようにしたらよいでしょうか。

Sub macro2()

'■フォルダ内のエクセルファイルを一括処理(今回はA1セルに1と入力のみ)
Sub call_folder_all_file_process()

Dim Path As String
Dim FName As String

'■ファイル名取得するフォルダパス、該当拡張子を入れる
Path = "C:\Users\user\Desktop\レジ\入力シート\宇和島"
FName = Dir(Path & ".xls") 'ワイルドカード()を使用し、xlsx拡張子のファイルを全て

'■Loopでファイルを取得→開く→処理→保存→閉じる
Do While FName <>""
Workbooks.Open Path & FName
Cells(1, 1) = 1
ActiveWorkBook.Save
ActiveWorkBook.Close

FName = Dir()
Loop
End Sub

を加工すれば、別ブックからの1シートのコピーができるのかと思いましたが
Cells(1, 1) = 1のところを、同編集すればよいか不明です。

コピー元ファイル：C:\Users\user\Desktop\レジ\入力シート\宇和島"　内にあります
コピー元ワークシート名：ジャンル
コピー先ファイル："C:\Users\user\Desktop\レジ\ジャンル.xlsx"
コピー先ワークシート名：ジャンル

コピーは、書式（色や罫線など）・値、すべてをそのままの形で
コピーしたいです。
シートそのもののコピー→挿入でも問題ありませんが、コピー元が1つ
コピー先が複数なので、そこがどうなるのかがよくわかりません。

meg_

2022/09/03 06:14

> VAB初心者で恐縮なのですが、お願いします。コードはどの程度書けますか？エクセルのVBAでの操作についてはどの程度理解されていますか？ > どのようにしたらよいでしょうか。具体的に分からないことは何でしょうか？

machakoko

2022/09/03 11:43

どの程度と言われましても、必要があるときにネットで調べて、どうにかこうにか動かしています。一から自分で書いたことはないです。ループをする方法は下記でみつけましたが、 Cells(1, 1) = 1 のところに、どうやって、シートのコピーをするように記述したらよいのかがわからないです。 '■フォルダ内のエクセルファイルを一括処理(今回はA1セルに1と入力のみ) Sub call_folder_all_file_process() Dim Path As String Dim FName As String '■ファイル名取得するフォルダパス、該当拡張子を入れる Path = "C:\Users\user\Desktop\レジ\入力シート\宇和島\" FName = Dir(Path & "*.xls") 'ワイルドカード(*)を使用し、xlsx拡張子のファイルを全て '■Loopでファイルを取得→開く→処理→保存→閉じる Do While FName <>"" Workbooks.Open Path & FName Cells(1, 1) = 1 ActiveWorkBook.Save ActiveWorkBook.Close FName = Dir() Loop End Sub

hatena19

2022/09/03 13:12 編集

まずは、このコードを、質問に追記してください。(この欄は、「質問への追記・修正の依頼」です。）さらに、下記についての情報も追記してください。＞一つ一つ開いたファイルの所定のシートに > 形式を選択して貼り付けをしなくてはなりません。所定のシートとはどのシートでしょうか。最初のシートですか。形式を選択して貼り付けとは、どのような形式でしょうか。すべて、値、....？また、シートそのもののコピー→挿入ではだめなんでしょうか。

行動規範の内容に同意します

回答3件

ありがとうございます。

motoSheet = "元シート"の部分を元となるファイルにすればよいのかなと思い
motoSheet = "C:\Users\user\Desktop\レジ\ジャンル.xlsx"
としてみましたが、
エラーとなり、デバッグで、下記が黄色くなりました。
Set rng = ThisWorkbook.Worksheets(motoSheet).Range(motoAddr)

投稿2022/09/05 00:08

machakoko

総合スコア3

ベストアンサー

とりあえず雰囲気だけ。

＜追記＞
・元ファイルの指定の箇所を少し修正。
・値貼り付けでなく元シートのコピーに変更。

VBA
1Sub call_folder_all_file_process()
2    
3    '■変数準備
4    Dim motoBook As Workbook
5    Dim motoSheet As Worksheet
6    Dim motoRange As Range
7    Dim motoAddr As String
8    
9    '■コピー元の範囲
10    Set motoBook = Workbooks.Open("C:\Users\user\Desktop\レジ\ジャンル.xlsx")
11    Set motoSheet = motoBook.Worksheets(1)
12    Set motoRange = motoSheet.UsedRange
13    motoAddr = motoRange.Address
14    
15    '■ファイル名取得するフォルダパス、該当拡張子を入れる
16    Dim Path As String
17    Dim FName As String
18    Path = "C:\Users\user\Desktop\レジ\入力シート\宇和島\"
19    FName = Dir(Path & "*.xlsx") 'ワイルドカード(*)を使用し、xlsx拡張子のファイルを全て
20    
21    '■Loopでファイルを取得→開く→処理→保存→閉じる
22    Application.DisplayAlerts = False
23    Do While FName <> ""
24        Dim wb As Workbook, ws As Worksheet
25        Set wb = Workbooks.Open(Path & FName)
26        Set ws = wb.Worksheets(1)
27        
28        motoSheet.Copy Before:=ws
29        ws.Delete
30        
31        wb.Save
32        wb.Close
33        FName = Dir()
34    Loop
35    Application.DisplayAlerts = True
36    
37End Sub