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

質問

• 複数ファイルデータを1つに纏める際、チェックボックスの値についても正常に出力するためのマクロのコードを教えてください。
• 入力ファイルのデータフォーマットは、各列に出力ファイルのタイトルがあり、8行目以降にデータがあります。数値形式でない記載もそのまま出力する必要があります。
• 出力ファイルの記載フォーマットは、A列に参加番号、B列からK列およびN列には入力ファイルのタイトルからデータを出力します。

回答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個の入力ファイルで本番のテストを実施する予定でおります。