複数ファイルデータを1つに纏めるチェックボックス有

質問

過去の質問タイトル『複数EXCELファイル中のデータを1つのファイルへ』、『複数ファイルのデータを1つのファイルへ纏めるマクロ』で大変お世話になっている者です。

HohoPapaさんからご教示頂きましたコードで、チェックボックス以外の値については、出力ファイルへ正常に纏める事が出来ました。
　更にお伝えして、入力ファイル中のチェックボックス(リンク設定有り)を出力ファイルへ吐き出すマクロのコードをご教示頂きたく質問させて頂きました。
奥が深く、私にはコードを修正出来るだけの力が有りません。
どうか、お教え下さるようお願いいたします。

・入力ファイルの記載フォーマットは以下の通りになります。
B列＝出力ファイルに付けるタイトルは6行目、データは8行目以降より
(出力ファイルには数値として吐き出したいが、入力ファイル中の記載は所々数値以外の形式で記載されている)
数値形式でない記載を数値形式で吐き出すのは困難である為、そのまま吐き出し。

C列＝出力ファイルに付けるタイトルは6行目、データは8行目以降より
D列＝出力ファイルに付けるタイトルは6行目、データは8行目以降より
E列＝出力ファイルに付けるタイトルは6行目、データは8行目以降より
F列＝出力ファイルに付けるタイトルは5行目、データは8行目以降より

G列＝出力ファイルに付けるタイトルは6行目、データは8行目以降より出力ファイルへは、日付表示で吐き出し。

H列＝出力ファイルに付けるタイトルは6行目、データは8行目以降より 出力ファイルへは、日付表示で吐き出し。

I列＝リンク設定の有るチェックボックス
　　値はオンにチェックがついており、[リンクするセル』＝『$Q$8』

J列＝リンク設定の有るチェックボックス
　　値はオンにチェックがついており、[リンクするセル』＝『$R$8』

K列＝リンク設定の有るチェックボックス
　　値はオンにチェックがついており、[リンクするセル』＝『$S$8』

L列＝関数式『=IF(AND(S8=TRUE,OR(Q8=TRUE,R8=TRUE)),"","右欄も要確認")』が入っています。

M列＝リンク設定の有るチェックボックス
　値はオンにチェックがついており、[リンクするセル』＝『$T$8』

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

Q列、R列、S列、T列＝8行目以降より『TRUE』、『FLASE』の文字入っている。

出力ファイルの記載フォーマットは以下の通りになります。
1行目のタイトルセルは、
A列＝『参加番号』
B列～K列、N列＝上記の入力ファイルのタイトルから

A列:2行目以降＝入力ファイル名の『課題参加者_23RF3001.xlsx』の『23RF3001』を入力ファイルのB列、C列、D列に記載が有る行数分記載。

B列～K列:2行目以降＝上記のB列～K列の入力データから吐き出し

N列:2行目以降＝上記のN列の入力データから吐き出し

回答No.7

HohoPapa · ベストアンサー

>マクロを起動した画面の後ろに隠れてしまって
この事象は当方では再現できないのでよくわかりません。

ともあれ、
・出力ファイルの保存場所を、入力ファイルを読み込む前に指定
・入力ファイル名のトップが
　　『課題参加者』拡張子が『xlsx』のファイルのみを読み込む設定
この２点、対応しました。
当方のコメントが遅くヤキモキさせたかもしれません。(._.)
本業に追われ、今となってしまいした。（見放していません）

Option Explicit

Const tgSheet = "Participant List"　'入力側シート名
Const A_Title = "ファイル名(hgehogeID)"
Const MyWidth = 8　'I,J,Kの列幅
Const RowHeight = 35　'2行目以下の行高

Dim BaseDir As String
Dim HitFileCount As Long
Dim PutBook As Workbook
Dim RowCount As Long

Sub sample()

　Dim PutPass As String
　Dim LastRow As Long
　Dim r As Long
　Dim c As Long

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

　With Application.FileDialog(msoFileDialogSaveAs)
　　.Show
　　PutPass = .SelectedItems(1)
　End With

　Set PutBook = Workbooks.Add
　HitFileCount = 0
　getFilesRecursive (BaseDir)

　'行高を設定
　LastRow = PutBook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
　PutBook.Sheets("Sheet1").Rows("2:" & LastRow).RowHeight = RowHeight

　With Application.FileDialog(msoFileDialogSaveAs)
　　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 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

　If Left(f.Name, 6) <> "科学登録者_" Then Exit Sub

　LogPut f.path
　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

　PutBook.Sheets("Sheet1").Range("B" & TLastRow & ":K" & TLastRow + FLastRow - 8).Value = _
　　GetSheet.Range("B8:K" & FLastRow).Value

　GetSheet.Range("N8:U" & FLastRow).Copy _
　　PutBook.Sheets("Sheet1").Range("N" & TLastRow & ":U" & TLastRow + FLastRow - 8)

　PutBook.Sheets("Sheet1").Range("A" & TLastRow & ":A" & TLastRow + FLastRow - 8).Value = _
　　Mid(f.Name, 7, 8)

　GetBook.Close

End Sub

Sub LogPut(MyText As String)
　Open ThisWorkbook.path & "\MyLog.txt" For Append As #1
　Print #1, Now & Chr(9) & MyText
　Close #1
End Sub

お礼

お世話になっております。
本日、マクロを本番で実施しまして、入力データ読み込み、出力ファイル書き込み共に問題無く終了出来ました。
稼働時間＝約30分　入力ファイル＝360個　出力数＝1235件
マクロは大切に使わせて頂きます。
本当に感謝です。ありがとうございました。
業務に追われる毎日ですので、VBAコードは少しずつ勉強を続けて行けたらと思います。

補足

お世話になっております。
VBAコードの修正、誠に有難うございました。
お忙しい中、本当に有難うございました。
希望しました通りにマクロが起動しまして、無事出力ファイルを保存する事が出来ました。
月曜日、本番を実施し最終確認をしまして『お礼』でご報告をさせて頂きます。ｽｸﾘﾌﾟﾄの修正を繰り返しお願いする度に心温まるご教示を頂けました事、感謝申し上げます。

回答No.6

HohoPapa

本番環境でなにやらエラーが起きたり
いつまでたっても終わらない、
といった症状があるようであれば、
後記手当を行うことで
マクロブック配置フォルダーに実行ログを出力できます。

マクロの実行中であっても
このログファイルを別な個所に複写し
メモ帳で開けば、どこまで進んでいるかを確認できます。

よかったら仕込んでみてください。

'//　以下をコード群の末尾に追記
Sub LogPut(MyText As String)
　Open ThisWorkbook.path & "\MyLog.txt" For Append As #1
　Print #1, Now & Chr(9) & MyText
　Close #1
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

　LogPut f.path　　　'この行を新たに追加
　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

　PutBook.Sheets("Sheet1").Range("B" & TLastRow & ":K" & TLastRow + FLastRow - 8).Value = _
　　GetSheet.Range("B8:K" & FLastRow).Value

　GetSheet.Range("N8:U" & FLastRow).Copy _
　　PutBook.Sheets("Sheet1").Range("N" & TLastRow & ":U" & TLastRow + FLastRow - 8)

　PutBook.Sheets("Sheet1").Range("A" & TLastRow & ":A" & TLastRow + FLastRow - 8).Value = _
　　Mid(f.Name, 7, 8)

　GetBook.Close

End Sub

お礼

引き続きお世話になっております。
お薦め下さいました、マクロを実行しました。
自宅PC上では、相変わらず、出力ファイル保存の画面が隠れてしまっているようで、出力ファイルの保存が出来ませんでした。
別のPCでは、出力ファイルの保存画面が見えましたので、保存しマクロは正常終了しました。
実行ログも確認する事が出来ました。
チェックボックスを吐き出さない出力ファイルの行数は1221行作成されており、入力ファイルも全て正常に読み込まれた事を確認しました。
マクロ稼働時間は約20分間でした。有難うございました。
出力ファイルは、マクロ稼働前に作成した方が良いのかなと思いました。マクロの修正が可能なようでしたら、
ご教示を頂けますと大変助かります。
入力ファイルも、指定したホルダーのみのデータだけ読み込む設定のコードのご教示をお願いいたします。
この2点を解決する事が出来れば問題無しになると思います。大変お手数でも、どうぞよろしくお願いいたします。

補足

大変お世話になっております。
続けてご教示を頂きまして、ありがとうございました。
VBAのｽｸﾘﾌﾟﾄでこんなきめ細かい事が出来てしまうのですね。
あれから、数回マクロを繰り返している内に、やっと気づいたのですが、マクロがフリーズしているのではなく、
入力ファイルの読み込みが全て完了後、出力ファイル名作成要求画面が、マクロを起動した画面の後ろに隠れてしまっている為のようです。マウスは正常に動いております。
これらを解決するには、出力ファイルの保存場所を、入力ファイルを読み込む前に指定すれば問題ないのかなとも思いました。マクロのコードの修正が可能でしたら、出力ファイル保存場所を指定してから、入力ファイルを読み込めるようにするコードをご教示頂けないでしょうか？
又は、もっと良い方法がありましたらご教示を頂けますと大変助かります。

それから、もう一点、ご教示を頂きたい事があります。
入力ファイルの読み込みですが、指定したホルダー内でのみ読み込むようにして、入力ファイル名のトップが『課題参加者』拡張子が『xlsx』のファイルのみを読み込む設定へのコードの修正をご教示頂けないでしょうか。
下記のコードは、指定したホルダーの更にその配下のホルダーのファイルも読み込むのだと思います。それを、指定したホルダー内だけのファイルを読み込むようにしたいのですが、どのようなコードにしら良いの分かりません。
getFilesRecursive (BaseDir)

本日、ご教示頂きました実行ログの出力方法をこれからｽｸﾘﾌﾟﾄを追加修正し、マクロを起動してみます。ありがとうございました。
マクロを起動中は、負荷がかかっているようで、タイミングによっては、入力ファイル読み込み途中で止まってしまう事が何度かありましたので、それらの確認には大変便利になるとおもいます。

チェックボックスはコードをコメントアウトして出力ファイルに吐き出さない事にしました。チェックボックスが入った出力ファイルは大変な負荷がかかって重たい物になりました。
大変お手数をお掛けしておりますが、VBAコードについて覚えるきっかけになっております。
マクロ実行後の結果は、再度ご報告させて頂きます。

回答No.5

HohoPapa

>チェックボックス転写のコード部分をコメントアウトするだけで、
>マクロ起動に影響しないようでしたら、
>コメントするコード部分のご教示を頂けましたら幸いです。

以下をコメントアウトすれば、ほかに影響なく、
単にチェックボックスが対象外になります。

　For r = 2 To LastRow
　　For c = 9 To 11
　　　With PutBook.Sheets("Sheet1").Cells(r, c)
　　　　StartX = .Left + Yohaku
　　　　StartY = .Top
　　　　EndX = CBoxWidth
　　　　EndY = .Height
　　　　PutBook.Sheets("Sheet1").CheckBoxes.Add(StartX, StartY, EndX, EndY).Select
　　　　Selection.Text = ""
　　　　Selection.Placement = xlMoveAndSize
　　　　If c = 9 Then
　　　　　Selection.Value = PutBook.Sheets("Sheet1").Range("$Q$" & r)
　　　　　Selection.LinkedCell = "$Q$" & r
　　　　ElseIf c = 10 Then
　　　　　Selection.Value = PutBook.Sheets("Sheet1").Range("$R$" & r)
　　　　　Selection.LinkedCell = "$R$" & r
　　　　ElseIf c = 11 Then
　　　　　Selection.Value = PutBook.Sheets("Sheet1").Range("$S$" & r)
　　　　　Selection.LinkedCell = "$S$" & r
　　　　End If
　　　End With
　　Next c
　Next r

>下記へコードを記載させて頂きました。
当方のコードのどの部分を書き換えたのかを説明してくれないと
確認できません。

回答No.4

HohoPapa

>『2個の入力データの出力は、データが入っている行は1行のみでしたが、
>出力ファイルの2行目にB列～H列が空欄、

複写元のレコードの対象範囲は、
>>'最終行を取得して、対象範囲を複写
>>FLastRow = GetSheet.Cells(Rows.Count, "B").End(xlUp).Row
B列、1024576行目から上方向に見て、
最初にデータ（あるいは式）の埋まったセルの行を見つけ
２行目から、この行までです。
B列に異常値が埋まっていないかを確認してください。

>　エラーメッセージ＝『RangeクラスのTextプロパティを設定できませんでした。』
集計元対象ブックをエラーの起きるブックを含む数ブックに絞り
テストしてみてください。
エラーが起きなければ、メモリー、あるいはエクセル仕様の限界かもしれません。

>データをケーブル形式にして、
>A列を降順で並べ替えを試したところチェックボックスのみ、降順にはなりませんでした。
チェックボックスは並べ替えには耐えられません。
並べ替えるのであれば、チェックボックス全数を削除し、
並べ替えを行った後でチェックボックスを新たに貼り付けなおす必要があります。
数が数だけに、vbaが必要です。

経験的には、チェックボックスの多さが気になりますし、
そもそもゴールとしているブックにチェックボックスが必要なのかという
疑問を感じます。

お礼

ご指摘頂いた件について、補足に書ききれず、下記へご報告させて頂きました。
・原因は、2個のファイル共に、B列:$2に半角スペースが入っている為で入力ファイルを修正しました。
　※説明が足りて無くてすみません。
　　今現在、sheet＝『Participant List』は50行分記載が出来る設定にしてあります。

・Q列～R列の値からも確認する事が出来るようにして頂いていますので、おっしゃる通り、出力ファイルへのチェックボックスの転写は無くても問題ないです。
　チェックボックス転写のコード部分をコメントアウトするだけで、マクロ起動に影響しないようでしたら、コメントするコード部分のご教示を頂けましたら幸いです。

補足

引き続き、ご教示頂きまして本当にありがたいです。
マクロ起動後、EXCELがフリーズをするようになりました。フリーズしている為、出力ファイルを保存する事が出来ず、どの部分でフリーズしたのかわかりません。下記へコードを記載させて頂きました。
大変お手数ですが、原因等、考えられる事がお分かりでしたらご教示頂けると大変助かります。
Option Explicit
Const tgSheet = "Participant List" '入力側シート名
Const A_Title = "課題ID"
Const MyWidth = 8 'I,J,Kの列幅
Const CBoxWidth = 2 'チェックボックスの列幅
Const Yohaku = 16
Const RowHeight = 35
Dim BaseDir As String
Dim HitFileCount As Long
Dim PutBook As Workbook
Dim RowCount As Long
Sub sample()
Dim PutPass As String
Dim LastRow As Long
Dim r As Long
Dim c As Long

Dim StartX As Double
Dim StartY As Double
Dim EndX As Double
Dim EndY As Double
'元データ格納フォルダーを取得
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
BaseDir = .SelectedItems(1)
End With
Set PutBook = Workbooks.Add
HitFileCount = 0
getFilesRecursive (BaseDir)
'チェックボックスを作成
LastRow = PutBook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
PutBook.Sheets("Sheet1").Range("I:K").ColumnWidth = MyWidth
PutBook.Sheets("Sheet1").Rows("2:" & LastRow).RowHeight = RowHeight
For r = 2 To LastRow
For c = 9 To 11
With PutBook.Sheets("Sheet1").Cells(r, c)
StartX = .Left + Yohaku
StartY = .Top
EndX = CBoxWidth
EndY = .Height
PutBook.Sheets("Sheet1").CheckBoxes.Add(StartX, StartY, EndX, EndY).Select
Selection.Text = ""
Selection.Placement = xlMoveAndSize
If c = 9 Then
Selection.Value = PutBook.Sheets("Sheet1").Range("$Q$" & r)
Selection.LinkedCell = "$Q$" & r
ElseIf c = 10 Then
Selection.Value = PutBook.Sheets("Sheet1").Range("$R$" & r)
Selection.LinkedCell = "$R$" & r
ElseIf c = 11 Then
Selection.Value = PutBook.Sheets("Sheet1").Range("$S$" & r)
Selection.LinkedCell = "$S$" & r
End If
End With
Next c
Next r
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
PutBook.Sheets("Sheet1").Range("B" & TLastRow & ":K" & TLastRow + FLastRow - 8).Value = _
GetSheet.Range("B8:K" & FLastRow).Value
GetSheet.Range("N8:U" & FLastRow).Copy _
PutBook.Sheets("Sheet1").Range("N" & TLastRow & ":U" & TLastRow + FLastRow - 8)
PutBook.Sheets("Sheet1").Range("A" & TLastRow & ":A" & TLastRow + FLastRow - 8).Value = _
Mid(f.Name, 7, 8)
GetBook.Close
End Sub

回答No.3

HohoPapa

N列に埋まっている計算式がシート（や、行）によって異なるとのことなので
VBAで計算式を埋めるのをやめ
N列に埋まっている計算式を複写するように変更しました。

また、U列も複写対象に含めました。

Option Explicit

Const tgSheet = "Participant List"　'入力側シート名
Const A_Title = "ファイル名(hgehogeID)"
Const MyWidth = 8　'I,J,Kの列幅
Const CBoxWidth = 2　 'チェックボックスの列幅
Const Yohaku = 16
Const RowHeight = 35

Dim BaseDir As String
Dim HitFileCount As Long
Dim PutBook As Workbook
Dim RowCount As Long

Sub sample()

　Dim PutPass As String
　Dim LastRow As Long
　Dim r As Long
　Dim c As Long

　Dim StartX As Double
　Dim StartY As Double
　Dim EndX As Double
　Dim EndY As Double

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

　Set PutBook = Workbooks.Add
　HitFileCount = 0
　getFilesRecursive (BaseDir)

　'チェックボックスを作成
　LastRow = PutBook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
　PutBook.Sheets("Sheet1").Range("I:K").ColumnWidth = MyWidth
　PutBook.Sheets("Sheet1").Rows("2:" & LastRow).RowHeight = RowHeight
　For r = 2 To LastRow
　　For c = 9 To 11
　　　With PutBook.Sheets("Sheet1").Cells(r, c)
　　　　StartX = .Left + Yohaku
　　　　StartY = .Top
　　　　EndX = CBoxWidth
　　　　EndY = .Height
　　　　PutBook.Sheets("Sheet1").CheckBoxes.Add(StartX, StartY, EndX, EndY).Select
　　　　Selection.Text = ""
　　　　Selection.Placement = xlMoveAndSize
　　　　If c = 9 Then
　　　　　Selection.Value = PutBook.Sheets("Sheet1").Range("$Q$" & r)
　　　　　Selection.LinkedCell = "$Q$" & r
　　　　ElseIf c = 10 Then
　　　　　Selection.Value = PutBook.Sheets("Sheet1").Range("$R$" & r)
　　　　　Selection.LinkedCell = "$R$" & r
　　　　ElseIf c = 11 Then
　　　　　Selection.Value = PutBook.Sheets("Sheet1").Range("$S$" & r)
　　　　　Selection.LinkedCell = "$S$" & r
　　　　End If
　　　End With
　　Next c
　Next r

　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

　PutBook.Sheets("Sheet1").Range("B" & TLastRow & ":K" & TLastRow + FLastRow - 8).Value = _
　　GetSheet.Range("B8:K" & FLastRow).Value

　GetSheet.Range("N8:U" & FLastRow).Copy _
　　PutBook.Sheets("Sheet1").Range("N" & TLastRow & ":U" & TLastRow + FLastRow - 8)

　PutBook.Sheets("Sheet1").Range("A" & TLastRow & ":A" & TLastRow + FLastRow - 8).Value = _
　　Mid(f.Name, 7, 8)

　GetBook.Close

End Sub

お礼

エラーが出たPC上で再びマクロを起動したところ、
エラー無く終了出来ましたので、ご連絡させて頂きました。
エラーで止まってしまったのは、PCのメモリーが足りない為でしょうか？
マクロ処理は、入力ファイルは357個で、出力された行は1223行でした。
マクロ処理時間は約1時間でした。

下記についても同じ結果となりましたので、
やはり、入力ファイルの問題だと思います。
『2個の入力データの出力は、データが入っている行は1行のみでしたが、出力ファイルの2行目にB列～H列が空欄、チェックボックスもチェック無し、自己申告結果も『内部運営管轄と相談下さい』、Q列～S列、U列は『FALSE』が1行余分に追加』

この後、マクロのテストを繰り返し試して見ます。

補足

スクリプトの修正有難うございます。
柔軟なスクリプトへ修正して頂きまして、大変有難かったです。
入力ファイル29個は、T列、U列ともに、出力ファイルへチェックボックスの値も含めて正常に吐き出す事が出来ました。

引き続き昨夜、本番前のテストを試し、今朝は別のPCで2回目の本番前のテストを実施しましたところ、今朝の別のPCでは、チェックボックス作成のところでエラーが出てマクロが止まってしまいました。

昨夜の本番前のテストを自宅で実施した時にも、エラーが出ましたので、入力ファイル用ホルダー内に有るホルダーを全て削除し、入力ファイルだけにしてから、マクロを再起動させたところ、最後まで処理出来ておりました。
※削除したホルダー内には同じ名前で古い入力ファイルが入っていて、それが原因かなと思いました。これらの古いファイルのデータは出力ファイルには吐き出したくないデータになります。

今朝の別のPCでも同じように、入力用ホルダー内のホルダーは全て削除後、マクロを起動させています。
EXCELのバージョンは自宅のPCと同じHome and Business 2019です。
何か設定が足りてないのでしょうか？
大変お手数ですが、対処方法をご教示頂けると大変助かります。

　エラーメッセージ＝『RangeクラスのTextプロパティを設定できませんでした。』

'チェックボックスを作成
LastRow = PutBook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
PutBook.Sheets("Sheet1").Range("I:K").ColumnWidth = MyWidth
PutBook.Sheets("Sheet1").Rows("2:" & LastRow).RowHeight = RowHeight
For r = 2 To LastRow
For c = 9 To 11
With PutBook.Sheets("Sheet1").Cells(r, c)
StartX = .Left + Yohaku
StartY = .Top
EndX = CBoxWidth
EndY = .Height
PutBook.Sheets("Sheet1").CheckBoxes.Add(StartX, StartY, EndX, EndY).Select
Selection.Text = ""

　昨夜自宅のPCで実施したマクロ処理結果は、以下の通りになります。
・入力データは357個、出力データ行数は1180行になりました。
　マクロ処理時間は、途中寝てしまった為、確認する事が出来ませんでしたが、2時間ぐらいだったと思われます。

・数個の入力データは、N列に関数式が無く文字が直接入っている事が分かりました。
　※目視確認で見つける事は困難でしたので、上記確認出来た事、大変有難かったです。

・2個の入力データの出力は、データが入っている行は1行のみでしたが、出力ファイルの2行目にB列～H列が空欄、
　チェックボックスもチェック無し、自己申告結果も『内部運営管轄と相談下さい』、Q列～S列、U列は『FALSE』が1行余分に追加されておりました。
　※入力データは各担当者が手入力で作成しておりますので、入力データの2行目に何か見えない文字でも入っているものと思われます。これらは問題御座いませんので、無視します。

・データをケーブル形式にして、A列を降順で並べ替えを試したところチェックボックスのみ、降順にはなりませんでした。
　※チェックボックスの特性だと思われます。出力データはファイル名順(昇順)で問題有りませんので、並べ替えはしないとします。

回答No.2

HohoPapa

チェックボックスの効率的な複写方法が別にあるのかもしれませんが
思いつかないので、チェックボックス以外を複写し
全数の複写が終わってから、チェックボックスをvbaで貼りつけました。

https://okwave.jp/qa/q10134520.html
と
https://okwave.jp/qa/q10137420.html
の継続です。

Option Explicit

Const tgSheet = "Participant List"　'入力側シート名
Const A_Title = "ファイル名(hgehogeID)"
Const MyWidth = 8　'I,J,Kの列幅
Const CBoxWidth = 2　 'チェックボックスの列幅
Const Yohaku = 16
Const RowHeight = 35

Dim BaseDir As String
Dim HitFileCount As Long
Dim PutBook As Workbook
Dim RowCount As Long

Sub sample()

　Dim PutPass As String
　Dim LastRow As Long
　Dim r As Long
　Dim c As Long

　Dim StartX As Double
　Dim StartY As Double
　Dim EndX As Double
　Dim EndY As Double

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

　Set PutBook = Workbooks.Add
　HitFileCount = 0
　getFilesRecursive (BaseDir)

　'チェックボックスを作成
　LastRow = PutBook.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
　PutBook.Sheets("Sheet1").Range("I:K").ColumnWidth = MyWidth
　PutBook.Sheets("Sheet1").Rows("2:" & LastRow).RowHeight = RowHeight
　For r = 2 To LastRow
　　For c = 9 To 11
　　　With PutBook.Sheets("Sheet1").Cells(r, c)
　　　　StartX = .Left + Yohaku
　　　　StartY = .Top
　　　　EndX = CBoxWidth
　　　　EndY = .Height
　　　　PutBook.Sheets("Sheet1").CheckBoxes.Add(StartX, StartY, EndX, EndY).Select
　　　　Selection.Text = ""
　　　　Selection.Placement = xlMoveAndSize
　　　　If c = 9 Then
　　　　　Selection.Value = PutBook.Sheets("Sheet1").Range("$Q$" & r)
　　　　　Selection.LinkedCell = "$Q$" & r
　　　　ElseIf c = 10 Then
　　　　　Selection.Value = PutBook.Sheets("Sheet1").Range("$R$" & r)
　　　　　Selection.LinkedCell = "$R$" & r
　　　　ElseIf c = 11 Then
　　　　　Selection.Value = PutBook.Sheets("Sheet1").Range("$S$" & r)
　　　　　Selection.LinkedCell = "$S$" & r
　　　　End If
　　　End With
　　Next c
　Next r

　'N列に計算式をセット
　PutBook.Sheets("Sheet1").Range(Cells(2, 14), Cells(LastRow, 14)).FormulaR1C1 = _
　　 "=IF(AND(RC[5]=TRUE,OR(RC[3]=TRUE,RC[4]=TRUE)),""合同設備等利用可能"",IF(RC[6]=TRUE,""合同設備等利用可能"",""内部運営管轄と相談下さい""))"

　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

　PutBook.Sheets("Sheet1").Range("B" & TLastRow & ":K" & TLastRow + FLastRow - 8).Value = _
　　GetSheet.Range("B8:K" & FLastRow).Value
　PutBook.Sheets("Sheet1").Range("O" & TLastRow & ":T" & TLastRow + FLastRow - 8).Formula = _
　　GetSheet.Range("O8:T" & FLastRow).Formula
　PutBook.Sheets("Sheet1").Range("A" & TLastRow & ":A" & TLastRow + FLastRow - 8).Value = _
　　Mid(f.Name, 7, 8)

　GetBook.Close

End Sub

補足

早速のVBAのｽｸﾘﾌﾟﾄのご教示、本当にありがとうございました。出力ファイルと入力ファイルを全て確認致しました。
入力ファイルの値は正常に出力ファイルに吐き出されておりました。チェックボックスの値も正常に入っておりました。
入力ファイルの非表示箇所を全て確認した所、
下記の設定になっている入力ファイルは29個中3個のみで、
N列＝関数式『=IF(AND(S8=TRUE,OR(Q8=TRUE,R8=TRUE)),"合同設備等利用可能",IF(T8=TRUE,"合同設備等利用可能","内部運営管轄と相談下さい"))』が入っています。
非表示となっていたQ列、R列、S列、T列＝8行目以降より『TRUE』、『FLASE』の文字入っています。

入力ファイルの29個中26個は、以下の設定になっておりました。
N列＝関数式『=IF(AND(S8=TRUE,OR(Q8=TRUE,R8=TRUE)),"合同設備等利用可能",IF(U8=TRUE,"合同設備等利用可能","内部運営管轄と相談下さい"))』が入っています。
非表示となっていたQ列、R列、S列、U列＝8行目以降より『TRUE』、『FLASE』の文字入っています。

しっかりと確認せずにご報告してしまいました。
大変お手数で恐縮なのですが、設定の多い方へ修正して頂けないでしょうか？

ｽｸﾘﾌﾟﾄ中でT8をU8への変更する場合の変更箇所等、ご教示頂けたら幸いです。
ｽｸﾘﾌﾟﾄの修正が済みましたら、400個の入力ファイルで本番のテストを実施する予定でおります。

回答No.1

SI299792

出力ファイルに付けるタイトルは6行目、データは8行目以降より
とありますが、画像を見る限り、タイトルは 1行目、データは 2行目です。
画像を信じます。

１行目のタイトルはあらかじめ入れておいて下さい。
フォルダ、シートの指定がないので
・入力ファイルは１シートしかない
・出力ファイルと入力ファイルは同じフォルダ
・L M T 列は対象外
・出力ファイルにこのマクロを入れる。
という前提で作りました。
Option Explicit
'
Sub Macro1()
　　Dim O As Worksheet
　　Dim FileName As String
　　Dim ROut As Long
　　Dim REnd As Long
'
　　Set O = ThisWorkbook.ActiveSheet
　　FileName = Dir(ThisWorkbook.Path & "\課題参加者_*.xlsx")
　　Range("A2:S" & Rows.Count).ClearContents
　　ActiveSheet.CheckBoxes.Delete
　　ROut = 2
　　Application.ScreenUpdating = False
'
　　Do While FileName > ""
　　　　Workbooks.Open ThisWorkbook.Path & "\" & FileName, False, True
　　　　FileName = Replace(FileName, ".xlsx", "")
'
　　　　If ROut < 8 Then
　　　　　　Rows("1:" & 8 - ROut).Delete
　　　　ElseIf ROut > 8 Then
　　　　　　Rows("8:" & ROut - 1).Insert
　　　　End If
　　　　REnd = Cells(Rows.Count, "B").End(xlUp).Row
　　　　O.Range("A" & ROut, "A" & REnd) = Mid(FileName, 7)
　　　　Range("B" & ROut, "K" & REnd).Copy O.Range("B" & ROut)
　　　　Range("N" & ROut, "S" & REnd).Copy O.Range("N" & ROut)
　　　　ROut = REnd + 1
　　　　ActiveWorkbook.Close False
　　　　FileName = Dir
　　Loop
End Sub

お礼

この度は、ご教示を頂き来まして、誠にありがとうございました。
ご教示頂きましたマクロは正常に稼働させる事が出来ましたし、短い稼働時間で作業が完了しました。
これをきっかけにVBAコードに慣れて多少の修正が出来るくらいになれたらと思っております。