Excel VBA 複数ブックのシートを１シートにまとめる

特定のローカルフォルダ内に
①マスターファイル.xls
②xxxx担当者Axxxx.xls
③　　　〃　B　〃
　　　　～
⑩　　　〃　I　〃
というファイルがあり、①～⑩には同じ[yyyy年ｍ月][master1][...2][...3]という4シートがあり、②～⑩のファイルの[yyyy年m月]というシートのデータを①のファイルの[yyyy年m月]のシートへ順にコピペでまとめたいのですが、webを見ていろいろ試しても上手くいきません
vbaは全くの初心者なので、こまかく解説を入れてもらえると助かります

＜条件＞
１．excelのバージョンは利用者毎にバラバラで2003～2010が使われています
２．②～⑩のコピー元の範囲はB51からAE120まで(50行名目がデータのタイトル行でそれ以前は集計されたデータがあります
３．①の貼付け先はB45から貼付けをしたい（44行目がデータのタイトル行でそれ以前は集計されたデータがあり、①のファイルは他支店と共有するので行や列の変更はできません）
４．貼付け順は担当者AからIまで指定をしたい(ファイル名を指定したい)
５．各シート名は毎月更新されていくので、シート名の[yyyy年m月]が変わります
６．それぞれのデータは値だけでなく、[master1][…2][…3]シートからデータを読み込んだ関数が含まれます
　　①～⑩は同じmasterデータを読み込むので関数を変える必要はありません（値貼付けになってもOKです）
７．[yyyy年m月]シートの特定の列には条件付き書式が含まれています
８．②～⑩のコピー元は担当者が行を追加したり削除したりするのでvbaで処理ができるようにしたいです
９．今後条件が変わっても修正できるようにできるだけ解説をつけてもらえると助かります

どうぞよろしくお願いいたします<m(__)m>

No.3 ベストアンサー 回答者： hiro40199210 回答日時： 2015/10/21 21:49

No.1のコードを修正しました。

xxxx担当者○xxxx.xlsを次々に開いて転記するのはNo.1のコードと同じです。
各xxxx担当者○xxxx.xlsの【B51～B列の最終行のAE列】を転記するデータにしました。
マスターブックの転記開始位置は【B列の最終行+1】なので、異なる行数のデータを転記しても、既にデータが存在している行に転記してしまうことはありません。
各xxxx担当者○xxxx.xlsの転記が完了したら、マスターブックのデータを最終行から調べて、転記したデータの空白行を削除します。【B列からAE列に一つも値が入力されていない行】


Sub Macro02()

Dim MasterBook As Workbook
Dim PathName As String
Dim FileSh As Worksheet
Dim i As Long, k As Long, t As Long
Dim PasteCell As Long
Dim MasterSh As Long
Dim Value1


Set MasterBook = ThisWorkbook

Application.ScreenUpdating = False

MasterBook.Activate
Set FileSh = Sheets("ファイル一覧")
'マスターファイルに[ファイル一覧]という名称のシートが存在しないとエラーになります。

PathName = "F:\データ\"
'パス名を変更してください。

For i = 1 To Sheets.Count
If Mid(Sheets(i).Name, 5, 1) = "年" And _
Right(Sheets(i).Name, 1) = "月" Then
MasterSh = i
Exit For
End If
Next
'このFor～Nextでマスターファイルのシートから、データシートを探します。

For k = 1 To FileSh.Range("A" & Rows.Count).End(xlUp).Row
Workbooks.Open Filename:=PathName & FileSh.Cells(k, 1).Value
'[ファイル一覧]シートのA1からA列の最終行までの値を順番に取り出して、
'PathNameと連結させたものが、Workbooks.OpenのFilenameになります。

For i = 1 To Sheets.Count
If Mid(Sheets(i).Name, 5, 1) = "年" And _
Right(Sheets(i).Name, 1) = "月" Then
t = Sheets(i).Cells(Rows.Count, 2).End(xlUp).Row

Value1 = Sheets(i).Range(Cells(51, 2), Cells(t, "AE"))
Exit For
End If
Next
'xxxx担当者○xxxx.xlsの【B列の最終行】を貼り付けるデータの最終行としました。

MasterBook.Sheets(MasterSh).Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(t - 50, 30) = Value1
' masterbook.Sheets(mastersh).range("B" & rows.Count).

'マスターブックのデータシートに転記します。転記開始位置はマスターブックのB列の最終行+1です。
'B列の最終行+1に転記するので、データの行数が変わっても問題ありません。

ActiveWorkbook.Close
'xxxx担当者○xxxx.xlsブックを閉じます。

Next
'次のxxxx担当者○xxxx.xlsブックを開きます。

For k = Range("b" & Rows.Count).End(xlUp).Row To 45 Step -1
If WorksheetFunction.CountIf(Range(Cells(k, 2), Cells(k, 10)), "*") = 0 Then
Rows(k).Delete shift:=xlUp
End If
Next
'マスターブックの最終行から45行の【B列からAE列に一つも値がなかった場合、その行を削除します】
Application.ScreenUpdating = True
End Sub

この回答へのお礼

バッチリ出来ました！
本当にありがとうございます
別のQへも回答ありがとうございます
そちらはこれから試してみますm(_ _)m

お礼日時：2015/10/23 17:55

No.2 回答者： hiro40199210 回答日時： 2015/10/21 01:09

PathName = "F:\データ\"はコードの18行目ではなく、もう少し後ろでした。

（２３行目あたりです）

この回答へのお礼

ありがとうございます
バッチリ出来ました！

但し説明不足（私の説明が間違っていました）で大変申し訳ないのですが、各担当者ファイルのデータを貼付けの際には空欄は詰めて張り付けたいんです…
担当者により80行までや120行目までバラバラで、毎月データ数（行数）も変わってきます

解決策はありますでしょうか

お礼日時：2015/10/21 17:30

No.1 回答者： hiro40199210 回答日時： 2015/10/20 21:20

複数ブックのデータを一つのシートにまとめるVBAを組みました。

★★★★★★★★★★★★★★★★★★★★★★
※必ず、マスターファイル.xlsを複製して、複製ファイルでテストをしてください。複製したブックのファイル名は何でも構いません。マスターファイルコピー.xlsでも仮.xlsでもOKです。
自動でブックを保存するコードは記述していませんので、予期せぬ結果になったら保存をせずに閉じれば元のブックのままです。
★★★★★★★★★★★★★★★★★★★★★★
xxxx担当者○xxxx.xlsファイルは値を取り出すだけなので、こちらは複製する必要はないです。


---------------------------準備-------------------------------------
複製したマスターファイルにシートを追加して、シート名を「ファイル一覧」にしてください。

シート「ファイル一覧」のA1からA9に、②xxxx担当者Axxxx.xls～⑩xxxx担当者Ixxxx.xlsを【拡張子も含めて】入力してください。（添付画像のようにしてください）
※ファイル名を入力したら、シートを非表示にしても問題ありません。

マクロコードの18行目
PathName = "F:\データ\"　を、データフォルダのパスに書き換えてください。

例　　PathName = "C:\Users\user\マイフォルダ\"
※パスの最後に【\】をつけてください。
----------------------------------------------------------------------

マスターファイル及び担当者ファイルのデータシート[yyyy年m月]を、自動で探すようにしましたが、ブックファイルのシート構成によってはうまく作動しません。

今回記述したコードでは、次の条件を両方とも満たすシートを、データシートとみなします。

①シート名の５番目の文字が[年]（１～４番目の文字は半角・全角を問いません）　
②最後の文字が[月]　
二つの条件を満たすシートが同一ブックに複数ある場合は、データシートを自動で探すことができません。

[2015年11月][2014年5月][２０１３年９月][出荷予定年月]
☝条件を満たすシート名の例
[14年2月]
☝条件を満たさないシート名の例
この条件では都合が悪い場合は教えてください。別の方法を考えます。


このコードは、マスターファイル（複製）のモジュールに貼り付けてください。
-------------------------マクロコード------------------------------------
Sub Macro01()

Dim MasterBook As Workbook
Dim PathName As String
Dim FileSh As Worksheet
Dim i As Long, k As Long
Dim PasteCell As Long
Dim MasterSh As Long
Dim Value1

PasteCell = 45
'最初のデータを貼り付ける行番号

Set MasterBook = ThisWorkbook

Application.ScreenUpdating = False
'画面の更新を停止

MasterBook.Activate
Set FileSh = Sheets("ファイル一覧")
'マスターファイルに[ファイル一覧]という名称のシートが存在しないとエラーになります。

PathName = "F:\データ\"
'パス名を変更してください。

For i = 1 To Sheets.Count
If Mid(Sheets(i).Name, 5, 1) = "年" And _
Right(Sheets(i).Name, 1) = "月" Then
MasterSh = i
Exit For
End If
Next
'このFor～Nextでマスターファイルのシートから、データシートを探します。

For k = 1 To FileSh.Range("A" & Rows.Count).End(xlUp).Row
Workbooks.Open Filename:=PathName & FileSh.Cells(k, 1).Value
'[ファイル一覧]シートのA1からA列の最終行までの値を順番に取り出して、
'PathNameと連結させたものが、Workbooks.OpenのFilenameになります。

For i = 1 To Sheets.Count
If Mid(Sheets(i).Name, 5, 1) = "年" And _
Right(Sheets(i).Name, 1) = "月" Then
Value1 = Sheets(i).Range("B51:AE120")
Exit For
End If
Next
'xxxx担当者○xxxx.xlsからデータシートを探して、B51:AE120の【値】を取り出します。
'取り出すのは【値】のみです。計算式は計算結果の値です。書式などは取り出しません。

MasterBook.Sheets(MasterSh).Range("B" & PasteCell).Resize(70, 30) = Value1
'マスターブックのデータシートに転記します。Resize(70,30)→B51:AE120の行数70、列数30

ActiveWorkbook.Close
'xxxx担当者○xxxx.xlsブックを閉じます。

PasteCell = PasteCell + 70
'データを貼り付ける行番号に、B51:AE120の行数70を加算します。
'初期値 45→115→185→255…

Next
'次のxxxx担当者○xxxx.xlsブックを開きます。

Application.ScreenUpdating = True
End Sub

-----------------------------------------------------------------

不具合が生じましたら、詳細を教えていただければ対策できるかもしれません。