フォルダ内の全てのファイルに貼り付けを行うマクロを作りたい

あるシートの書式を更新させたいのですがファイルが400以上あるため自動でできたらなあと考えています

excelブックAの　Sheetあ　のSheet内全範囲をコピーしてフォルダ内の全てのexcelブックに張り付けるマクロはどう組めばよいでしょうか
貼り付け先のシートは全てブックAの　Sheetあ　と同一ですがそれぞればらばらのSheetを選択した状態で保存されているため各ブックを開いた後　Sheetあ　を選択しなおす必要があります

https://oshiete.goo.ne.jp/qa/9198080.html
URL先で以前似たような質問をさせて頂いたのですが勉強不足のため応用ができず・・・
構想ではこんな感じのマクロを組めばよいのかと考えていますがうまく組めず悩んでいます

1.ブックAの　Sheetあ　を全範囲選択してコピー
2.同じフォルダ内の別のブックを開いて　Sheetあ　に貼り付け
3.B7セルを選択(張り付けた後全範囲選択したままだと使い勝手が悪い為B7セルを選択しておきたい)
4.保存して閉じる
5.次のブックを開く
6.フォルダ内のブックすべてに適用するまで1～5の繰り返し

No.1 ベストアンサー 回答者： siffon9 回答日時： 2016/03/12 18:28

こんな感じで如何でしょう？

-----------------------------------
Sub sample()
Dim fileName As String
Dim wsName As String: wsName = "あ" '対象ワークシート名

Application.ScreenUpdating = False '各ファイルの変更処理を表示させない
Application.DisplayAlerts = False '保存時メッセージを表示させない
ChDir ThisWorkbook.Path
fileName = Dir("*.xls?") 'フォルダ内の最初のエクセルファイル名を取得
Do While fileName <> ""
If fileName <> ThisWorkbook.name Then 'マクロのあるファイルでなければ
With Workbooks.Open(fileName) 'ファイルオープン
ThisWorkbook.Worksheets(wsName).Cells.Copy .Worksheets(wsName).Cells 'コピー
.Worksheets(wsName).Range("B7").Select
.Close savechanges:=True '保存＆クローズ
End With
End If
fileName = Dir() 'フォルダ内の次のエクセルファイル名を取得
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

この回答へのお礼

お礼が遅くなってしまい申し訳ありません
おかげさまでうまくいきました！ありがとうございます！！(´∀｀*)

お礼日時：2016/03/16 18:51

No.3 回答者： siffon9 回答日時： 2016/03/13 10:20

No.1です。

>No.2さん
ご指摘ありがとうございます。
確かに、エクセルファイルの対象のシートがアクティブでない状態で保存されていた場合のテストをしておりませんでした。

No.2 回答者： OverTheGalaxy 回答日時： 2016/03/13 01:21

No1に補足します。

>.Worksheets(wsName).Range("B7").Select
直接他シートのセルを選択することは普通には出来ません。まずシート選択してからセル選択する必要があります。
.Worksheets(wsName).Activate
Range("B7").Select

この回答へのお礼

補足ありがとうございます！助かりました！(∩´∀｀)∩

お礼日時：2016/03/16 18:51