複数ファイルのデータを1つのファイルへ纏めるマクロ

質問

マクロの実行で、Excel形式の約400個のファイル中のデータを１つの出力ファイルへ纏める為のマクロを作成したいのですが、VBAの初心者で、ｽｸﾘﾌﾟﾄの書き方が分からず大変困っております。
入力ファイルの中身は頻繁に追加、削除を繰り返しており、そのたびに入力ファイルを目視確認後、出力ファイルを手動で修正している状況でございます。
大変お手数ですが、マクロがお分かりの方がいらっしゃいましたら、ご教示を宜しくお願い致します。
・入力ファイルは、以下ような名前になっております。
課題参加者_23RF3001.xlsx
課題参加者_23RF3005.xlsx
課題参加者_23RF3072★.xlsx
課題参加者_23RF3073.xlsx
課題参加者_23RF3199.xlsx
課題参加者_23RF3543.xlsx
・入力ファイルのデータは、添付しました画面イメージの通りで、
　フォーマットは全て同じです。
・出力ファイルに吐き出す入力データはB列～K列とN列になります。
・出力ファイルのタイトルは、1番目に呼び出したファイルのB列～K列とN列を使う。
・出力ファイルのA列のデータは、入力ファイル名の『23RF3001』、『23RF3543』などを入力データ分入れる。
・出力ファイルのタイトルに使う、入力ファイルのタイトルは以下のようになっています。　
　B列～E列のタイトルは、6行目、7行目が結合されたセルに入っています。
　F列のタイトルは、5行目、6行目、7行目が結合したセルに入っています。
　G列～H列のタイトルは、6行目、7行目が結合されたセルに入っています。
　I列～K列のタイトルは、7行目のセルに入っています。
　N列のタイトルは、6行目、7行目が結合されたセルに入っています。
・出力ファイルへ吐き出したい、入力ファイルデータの範囲は、
　B列～K列の8行目以降とN列の8行目以降のデータになりますが、
　『職員番号』、『名前』、『部門』に記載が有る行のみを出力ファイルへ吐き出します。
　N列はリストの最後の行まで文字が入力されていますが、
　N列についても、上記の『職員番号』、『名前』、『部門』に記載が有る行のみを出力ファイルへ吐き出します。
・出力データへ吐き出す時の書式フォーマットは以下の通りになります。
　A列＝文字形式
　B列＝数値形式
　C列～F列＝文字形式
　G列、H列＝日付形式
　I列～K列＝チェックボックス(フォームコントロール形式(入力データと同じ形式))
　N列＝文字形式
・入力データは今の所50行まで入力可能としています。

回答No.4

HohoPapa · ベストアンサー

https://okwave.jp/qa/q10134520.html
の続きでしょうから、双方の内容を加味して
コードを書いてみました。

なお、チェックボックスに、リンク先セルの設定はないことが前提です。
また、
https://okwave.jp/qa/q10134520.html
で採用していたSQL文は使っていない（今回のケースでは使えない）ので、
性能は格段に落ちると思います。

Option Explicit

'以下を参照設定
'Microsoft Scripting Runtime

Const tgSheet = "Participant List"　'入力側シート名
Const A_Title = "ファイル名(hgehogeID)"
Dim BaseDir As String
Dim HitFileCount As Long
Dim PutBook As Workbook
Dim RowCount As Long

Sub sample()

　Dim PutPass As String

　'元データ格納フォルダーを取得
　With Application.FileDialog(msoFileDialogFolderPicker)
　　.Show
　　BaseDir = .SelectedItems(1)
　End With

　'保存先ブックを新規オープン
　Set PutBook = Workbooks.Add

　'メイン処理をコール
　HitFileCount = 0
　getFilesRecursive (BaseDir)

　'保存先のフルパスを取得して保存し、クローズ
　With Application.FileDialog(msoFileDialogSaveAs)
　　.Show
　　PutPass = .SelectedItems(1)
　　PutBook.SaveAs (PutPass)
　　PutBook.Close
　End With

　MsgBox Format(HitFileCount, "0") & "件のファイル処理終了"

End Sub

'フォルダー、ファイルを総当たり
Sub getFilesRecursive(path As String)

　Dim FSO As FileSystemObject: Set FSO = New FileSystemObject
　Dim objFolder As folder
　Dim objFile As file

　'フォルダーを個々に取得
　For Each objFolder In FSO.GetFolder(path).SubFolders
　　getFilesRecursive objFolder.path
　Next

　'ファイルを個々に取得
　For Each objFile In FSO.GetFolder(path).Files
　　If UCase(FSO.GetExtensionName(objFile.path)) = "XLSX" Then
　　　execute objFile
　　End If
　Next

End Sub

'取得したファイルのデータを取得して格納する
Sub execute(f As file)

　Dim GetBook As Workbook
　Dim GetSheet As Worksheet
　Dim FLastRow As Long
　Dim TLastRow As Long
　Dim r As Long

　'対象のファイルを数える
　HitFileCount = HitFileCount + 1

　'ファイルを開いてシートを取得
　Set GetBook = Workbooks.Open(f.path)
　Set GetSheet = GetBook.Sheets(tgSheet)

　If HitFileCount = 1 Then
　　PutBook.Sheets("Sheet1").Range("B1:E1").Value = _
　　　GetSheet.Range("B6:E6").Value
　　PutBook.Sheets("Sheet1").Range("F1").Value = _
　　　GetSheet.Range("F5").Value
　　PutBook.Sheets("Sheet1").Range("G1:H1").Value = _
　　　GetSheet.Range("G6:H6").Value
　　PutBook.Sheets("Sheet1").Range("I1:K1").Value = _
　　　GetSheet.Range("I7:K7").Value
　　PutBook.Sheets("Sheet1").Range("N1").Value = _
　　　GetSheet.Range("N6").Value
　　PutBook.Sheets("Sheet1").Range("A1").Value = A_Title
　　RowCount = 2
　End If

　'最終行を取得して、対象範囲を複写
　FLastRow = GetSheet.Cells(Rows.Count, "B").End(xlUp).Row
　TLastRow = PutBook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row + 1
　GetSheet.Range("B8:K" & FLastRow).Copy _
　　Destination:=PutBook.Sheets("Sheet1").Range("B" & TLastRow & ":K" & TLastRow + FLastRow - 8)
　GetSheet.Range("N8:N" & FLastRow).Copy _
　　Destination:=PutBook.Sheets("Sheet1").Range("N" & TLastRow & ":N" & TLastRow + FLastRow - 8)

　'元ファイルクローズ
　GetBook.Close

End Sub

補足

引き続きVBAのｽｸﾘﾌﾟﾄをご教示頂き誠に有難うございました。
昨夜からずっと、前回ご教示頂いたｽｸﾘﾌﾟﾄを使って、色々と試していましたが、VBAの知識が全くゼロの為、無茶苦茶エラーが出まくって思うようにｽｸﾘﾌﾟﾄが動かず困っておりました

早速、作成頂きましたｽｸﾘﾌﾟﾄを実行させて頂きました。
ｽｸﾘﾌﾟﾄはエラー無しで起動し、全ての入力ファイルを読み込む事ができました。

出力ファイルを確認すると、下記のような結果になりましたので、ｽｸﾘﾌﾟﾄをいじって見ましたが、エラーが出るばかりで一向に解決する事が出来ませんでした。
大変お手数ですが、下記について解決出来る対処がありましたら、どうぞご教示をよろしくお願いします。

・出力ファイルの『A列:$1』には『ファイル名(hgehogeID)』の記載はありますが、2行以降は空白のままとなっています。
→
前回のｽｸﾘﾌﾟﾄの下記を追加してみましたが、下記だけ追加したのでは、エラーが出てだめでした。
'ファイル名出力
TRng1 = "A" & Format(RowCount, "0") & ":A" & Format(RowCount + 42, "0")
PutBook.Sheets("Sheet1").Range(TRng1).Value = Mid(f.Name, 7, 8)

・出力ファイルのI列～K列のチェックボックスとN列について、質問で添付させて頂きました図でご説明しますと、
　B列～H列の値と同じ行数分、赤枠の下の行のチェックボックスが入っているようです。
　K列のチェックボックスは大半はL列に入っています。
　出力側の全てのチェックボックスは、チェックが付いてない状態です。
　出力側のN列も上記と同じで、赤枠の下の行の値が入っています。
→
　チェックボックスを出力ファイルへ吐き出すのは、
　色々と大変なように感じました。
　何とか、N列の値だけでも吐き出したいのですが、
　下の行を出力してしまう原因が全く分かりませんでした。入力ファイル側に原因が有るのか？

・出力ファイルはM列が有り、全て空欄でした。
→
こちらの列は、出力ファイル側のタイトルも空白でしたので、このままとします。

回答No.5

HohoPapa

>・出力ファイルの『A列:$1』には『ファイル名(hgehogeID)』の記載はありますが、
>2行以降は空白のままとなっています。
これは、コードを書き漏れていました。直しました。

チェックボックスは要求通りに複写したつもりです。
オン、オフが期待通りかどうかは別にして、
期待通り複写されていませんでしょうか？

オン、オフが期待通りかどうかは
先に説明しました、
>チェックボックスに、リンク先セルの設定はないことが前提です
この前提を満たしていない可能性を疑います。

転記元のシートの適当なチェックボックスを右クリックし
コントロールの書式設定を選択し、添付画像個所を確認してください。
このが空欄であれば正しく複写できるはずです。

ここにセルのアドレスが埋まっているようなら、
チェックボックスの配置セルとリンクするセルの関係を明らかにしてください。
（同じセルとか、1行したとか、右側のセルといった関係です）

>・出力ファイルはM列が有り、全て空欄でした。
？？そもそもＬ，Ｍ列は転記対象ではないものと判断しました。

先のスレッドで伝えた
>入力側のシートサンプル、
>出力側シートサンプルを画像付きで説明してくれないと
>理解できません。
このうち、
出力側シートサンプルの提示が無いので、期待されていることが
当方に伝わらないのではないかと思います。

再び、このスレッドは閉じ、
もう1度、新たにスレッドを起こしたほうがいいと思います。

Option Explicit

'以下を参照設定
'Microsoft Scripting Runtime

Const tgSheet = "Participant List"　'入力側シート名
Const A_Title = "ファイル名(hgehogeID)"
Dim BaseDir As String
Dim HitFileCount As Long
Dim PutBook As Workbook
Dim RowCount As Long

Sub sample()

　Dim PutPass As String

　'元データ格納フォルダーを取得
　With Application.FileDialog(msoFileDialogFolderPicker)
　　.Show
　　BaseDir = .SelectedItems(1)
　End With

　'保存先ブックを新規オープン
　Set PutBook = Workbooks.Add

　'メイン処理をコール
　HitFileCount = 0
　getFilesRecursive (BaseDir)

　'保存先のフルパスを取得して保存し、クローズ
　With Application.FileDialog(msoFileDialogSaveAs)
　　.Show
　　PutPass = .SelectedItems(1)
　　PutBook.SaveAs (PutPass)
　　PutBook.Close
　End With

　MsgBox Format(HitFileCount, "0") & "件のファイル処理終了"

End Sub

'フォルダー、ファイルを総当たり
Sub getFilesRecursive(path As String)

　Dim FSO As FileSystemObject: Set FSO = New FileSystemObject
　Dim objFolder As folder
　Dim objFile As file

　'フォルダーを個々に取得
　For Each objFolder In FSO.GetFolder(path).SubFolders
　　getFilesRecursive objFolder.path
　Next

　'ファイルを個々に取得
　For Each objFile In FSO.GetFolder(path).Files
　　If UCase(FSO.GetExtensionName(objFile.path)) = "XLSX" Then
　　　execute objFile
　　End If
　Next

End Sub

'取得したファイルのデータを取得して格納する
Sub execute(f As file)

　Dim GetBook As Workbook
　Dim GetSheet As Worksheet
　Dim FLastRow As Long
　Dim TLastRow As Long
　Dim r As Long

　'対象のファイルを数える
　HitFileCount = HitFileCount + 1

　'ファイルを開いてシートを取得
　Set GetBook = Workbooks.Open(f.path)
　Set GetSheet = GetBook.Sheets(tgSheet)

　If HitFileCount = 1 Then
　　PutBook.Sheets("Sheet1").Range("B1:E1").Value = _
　　　GetSheet.Range("B6:E6").Value
　　PutBook.Sheets("Sheet1").Range("F1").Value = _
　　　GetSheet.Range("F5").Value
　　PutBook.Sheets("Sheet1").Range("G1:H1").Value = _
　　　GetSheet.Range("G6:H6").Value
　　PutBook.Sheets("Sheet1").Range("I1:K1").Value = _
　　　GetSheet.Range("I7:K7").Value
　　PutBook.Sheets("Sheet1").Range("N1").Value = _
　　　GetSheet.Range("N6").Value
　　PutBook.Sheets("Sheet1").Range("A1").Value = A_Title
　　RowCount = 2
　End If

　'最終行を取得して、対象範囲を複写
　FLastRow = GetSheet.Cells(Rows.Count, "B").End(xlUp).Row
　TLastRow = PutBook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row + 1
　GetSheet.Range("B8:K" & FLastRow).Copy _
　　Destination:=PutBook.Sheets("Sheet1").Range("B" & TLastRow & ":K" & TLastRow + FLastRow - 8)
　GetSheet.Range("N8:N" & FLastRow).Copy _
　　Destination:=PutBook.Sheets("Sheet1").Range("N" & TLastRow & ":N" & TLastRow + FLastRow - 8)
　PutBook.Sheets("Sheet1").Range("A" & TLastRow & ":A" & TLastRow + FLastRow - 8).Value = _
　　Mid(f.Name, 7, 8)

　'元ファイルクローズ
　GetBook.Close

End Sub

お礼

早速のご教示ありがとうございました。
・コードを書き漏れていました。直しました。
　→
　修正頂いたマクロを実行し、A列に値が正常に入りました。ありがとうございました。

・チェックボックスに、リンク先セルの設定はないことが前提ですこの前提を満たしていない可能性を疑います。
　→
　お察しの通り、表示範囲外(Q列、R列、S列、T列)には、『TRUE』、『FLASE』の文字が入っておりました。
　全く気付いておらず、説明がなってなくて申し訳ありませんでした。

　入力ファイル中のチェックボックスの[コントロールの書式設定]は以下の通りです。
　　　I列＝値はオンにチェックがついており、[リンクするセル』＝『$Q$8』
　　　J列＝値はオンにチェックがついており、[リンクするセル』＝『$R$8』
　　　K列＝値はオンにチェックがついており、[リンクするセル』＝『$S$8』
　　　M列＝値はオンにチェックがついており、[リンクするセル』＝『$T$8』

　L列には以下の関数式が入っていました。
　　=IF(AND(S8=TRUE,OR(Q8=TRUE,R8=TRUE)),"","右欄も要確認")

　N列には以下の関数式が入っていました。
　　=IF(AND(S8=TRUE,OR(Q8=TRUE,R8=TRUE)),"合同設備等利用可能",IF(T8=TRUE,"合同設備等利用可能","内部運営管轄と相談下さい"))

　以上の事から、ご指摘の通り、入力ファイルと出力ファイルの画面イメージを作成しまして、
　再度のご質問をさせて頂きたいと思います。
　単純にマクロ処理を考えておりました事、深く反省です。こんなに奥が深いとは思ってもいませんでした。
　そして、ここまでマクロを作成下さいまして、感謝の限りです。
　次の質問でも、お力添えを頂けましたら大変幸甚です。

回答No.3

SI299792

この画像、行が出ていません。転記元、転記先共７行からとします。
チェックボックスのリンクするセルがどこか解りません。チェックボックスのあるセルと同じセルになっている前提です。
フォルダはこのマクロを入れたワークブックと同じフォルダとします。
１ブック１シートとします。
Option Explicit
'
Sub Macro1()
　　Dim O As Worksheet
　　Dim FileName As String
　　Dim REnd As Long
'
　　Set O = ThisWorkbook.ActiveSheet
　　FileName = Dir(ThisWorkbook.Path & "\課題参加者_*.xlsx")
　　Range("B7:L" & Rows.Count).ClearContents
　　ActiveSheet.CheckBoxes.Delete
　　Application.ScreenUpdating = False
'
　　Do While FileName > ""
　　　　Workbooks.Open ThisWorkbook.Path & "\" & FileName, False, True
　　　　REnd = Cells(Rows.Count, "B").End(xlUp).Row
　　　　O.Rows("7:" & REnd).Insert
　　　　Range("B7:K" & REnd).Copy O.[B7]
　　　　Range("N7:N" & REnd).Copy O.[L7]
　　　　Workbooks(FileName).Close False
　　　　FileName = Dir
　　Loop
End Sub

お礼

マクロのコードのご教示、誠にありがとうございました。

入力ファイルにリンクの設定があるチェックボックスが
有りまして、その事に気付かず質問が口足らずでした。
再度、それらを含めた質問をさせて頂きます。

回答No.2

imogasi

何を聞いてもても良い質問コーナながら、これでは回答者側で、相当な長時間の労務の提供依頼になる見込。それをやってくれと言うのは、どうかな。常識では頼まないだろう。
その他に
（１）状況や課題の説明が、数十行の、文字の文章では出来ないと思う。
　　業者が請け負うとしても、資料も見せてもらって、数時間のミーティングはするだろう。
　　頼む目的さえ質問に、説明されていないのでは。
（２）実際実行してテストすべきでしょうが、テストデータがない。回答者では作れない。
（３）ブックの数量（データ量）が多くて、ブックごとに細切れで、内容的に例外がないのかどうか。それらの諸々の理解が行き届くかどうか。
（４）質問の説明ぶりから、質問者は、多少でもシステムを経験した人とは思えない。
ですから、要望に応えるのは無理でしょう。
ーー
　元々、エクセルで処理する類のものではないだろうと思う。
詳しくは判らないが、どうも人事のスキルやジョブ管理システムのように見える。
システム課題そのものはありふれた類型であるようだが。
そういう課題にふさわしいソフト（は相当あるはずでそれ）を、この際導入検討をしてはどうか。
異動の更新や、検索などにも特有のニーズがあるだろう。
データの移行切り替えが必要だが、それに適当な時期ではないか。
データベース的なものになるのではないかと思う。データを多くためておいて、目的に応じて検索し
目的表などを作成する。エクセルはその時期時期で、１枚のシートになりがち。エクセル以前から
一般に、システム部門ではそれは痛感されていた。素人がエクセルで何とかその場を切り抜けようとした結果が、今なにか、それでは限界に来たのではないか。
全般に、システムというモノを甘く見過ぎではないか。内容面も経済的コスト面でも、コストがかかるものだということも含めて。

お礼

ご教示ありがとうございました。
確かに、おっしゃる通りでございます。
VBAｽｸﾘﾌﾟﾄは大変奥が深いです。

補足

色々とご指摘を頂きましてありがとうございます。
先ずは、自分でVBAのスクリプトを組み合わせながら作成してみます。

回答No.1

kon555

残念ながらというか、書かれているようなシチュエーションで問題なく動作するマクロを、このようなQAサイト上のやり取りで作成するのは極めて困難です。
　一方で、VBAの処理としてはそこまで高度というわけではなく、初心者レベルでもある程度時間をかければ作成は可能でしょう。
　問題は条件が多く、また元々のレイアウトなどが自動処理に不向きな事なので、データさえあれば何とでもなります。

　なので貴方自身がVBAのスキルを身につけて、作業を少しずつでも合理化していく事をオススメします。
　ExcelVBAは参考になるサイトも多く、独学でも実務で使えるレベルにはなれます。またある程度まで貴方が組めれば、分からない所をこうしたサイトで質問する事も出来ます。

　一応学習用のオススメサイトを紹介しておきます。
https://excel-ubara.com/excelvba1/
https://my-tax-nology.com/the-way-of-starting-excel-vba-anyway/amp

お礼

ご教示ありがとうございました。
説明に口足らずな所が有り、又リンクの設定があるチェクボックスの事に気付かず質問をしておりました。
再度、これらチェックボックスを含めた質問をさせて頂きます。