#複数bookを集計する
「アンケートフォームなどで見かける「チェックボックス(checkbox,optionbutton)」を使って、複数のブックを集計する」

全体的にこんな感じです。
Excel checkbox optionbutton 重いチェックボックス対策　超軽量チェックボックスで使っていたシートを使います。
「集計表転送」ボタンを追加しています。このボタンでマクロを起動します。
ファイル保存で自動転記もできます。よかったら改造してみてください。

###「集計表転送」シートを追加して、転送先設定と転送データを設定します
「集計表転送」シートは手作りしてください。
こんな感じで計算式を設定しました。

集計表更新で、こんな感じで追記します。KEY項目で更新もします。
簡単には次の動作をします。
１．転送先は完全自動作成　保存先のフォルダ、ファイル、シートをマクロで作成
２．集計表転送シートのタイトルをコピペ
３．値をコピペ
４．保存して終了

all

Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Function func_GetLocalTime() As String
    Dim t   As SYSTEMTIME
    Call GetLocalTime(t)                ' 現在日時取得 -> yyyy/mm/dd hh:mm:ss.fff
    func_GetLocalTime = Format(t.wYear, "0000") & "/" & Format(t.wMonth, "00") & "/" & Format(t.wDay, "00") _
    & " " & Format(t.wHour, "00") & ":" & Format(t.wMinute, "00") & ":" & Format(t.wSecond, "00") _
    & "." & Format(t.wMilliseconds, "000")
End Function

'---------------------
' 主処理
'---------------------
Sub button1_Click()
    Dim outFolderName As String
    Dim outExcelFileName As String
    Dim outFileFullPath As String
    Dim outSheetName As String
    Dim this2sheet As Worksheet
    Dim oFS As Object
    
    Set oFS = CreateObject("Scripting.FileSystemObject")
    Set this2sheet = Sheets("集計表転送")
    
    On Error Resume Next
    outFolderName = oFS.GetAbsolutePathName(this2sheet.Range("B2").Value)
    If Err.Number <> 0 Then
        MsgBox "転送先フォルダ[" & this2sheet.Range("B2").Value & "]不正"
        End
    End If
    
    If func_sheetNameCheck(this2sheet.Range("B3").Value) = False Then
        MsgBox "転送先ファイル名[" & this2sheet.Range("B3").Value & "]不正1"
        End
    End If
    outExcelFileName = oFS.GetFileName(oFS.GetAbsolutePathName(this2sheet.Range("B3").Value))
    If Err.Number <> 0 Then
        MsgBox "転送先ファイル名[" & this2sheet.Range("B3").Value & "]不正2"
        End
    End If
    If oFS.GetBaseName(outExcelFileName) = "" Then
        MsgBox "転送先ファイル名[" & this2sheet.Range("B3").Value & "]不正3"
        End
    End If
    On Error GoTo 0
    
    outFileFullPath = outFolderName & "\" & outExcelFileName
    
    outSheetName = this2sheet.Range("B4").Value
    If func_sheetNameCheck(outSheetName) = False Then
        MsgBox "シート名[" & outSheetName & "]不正"
        End
    End If
    
    If Not (oFS.FolderExists(outFolderName)) Then   '転送先フォルダ存在確認 & 無ければ作成 & 作成失敗 → 終了
        Call func_CreateFolder(outFolderName)
    End If
    If Not (oFS.FolderExists(outFolderName)) Then
        MsgBox "転送先フォルダ[" & outFolderName & "]作成不能、手作業で作成してください"
        End
    End If

    '転送先ファイル存在確認 & 無ければ作成
    If oFS.FileExists(outFileFullPath) Then
        If Not (func_worksheetexist(Workbooks.Open(outFileFullPath), outSheetName)) Then        'シートが存在しない
            Call sheet_add(outFileFullPath, outSheetName, outExcelFileName)                     '転送先シート作成
            Call title_add(this2sheet.Name, outFileFullPath, outSheetName, outExcelFileName)    '転送先ファイルタイトル作成
        End If
    Else
       '転送先ファイル存在しない
       Call book_add(outFileFullPath, outSheetName, outExcelFileName)                           '転送先ファイル&シート作成
       Call title_add(this2sheet.Name, outFileFullPath, outSheetName, outExcelFileName)         '転送先ファイルタイトル作成
    End If
    
    'データ転送
    Call data_add(this2sheet, outFileFullPath, outSheetName, outExcelFileName)                  '転送先ファイルタイトル作成
    
    Set this2sheet = Nothing
    Set oFS = Nothing
End Sub

'---------------------
' worksheet名チェック
'---------------------
Function func_sheetNameCheck(checkSheetName As String)
    func_sheetNameCheck = False
    Dim c As Variant
    If checkSheetName = "" Then Exit Function            '(1)空欄
    If Len(checkSheetName) > 31 Then Exit Function       '(3)文字数が31文字以内
    For Each c In Array(":", "\", "/", "?", "*", "[", "]", "<", ">", "|")  '(2)不正な文字
        If InStr(checkSheetName, c) > 0 Then Exit Function
    Next
    func_sheetNameCheck = True
End Function

'---------------------
' worksheet名存在判定
'---------------------
Function func_worksheetexist(checkWorkbook As Object, workSheetName As String)
    func_worksheetexist = False
    Dim stobj As Object
    For Each stobj In checkWorkbook.Sheets
        If stobj.Name = workSheetName Then
            func_worksheetexist = True
            Exit For
        End If
    Next
End Function

'---------------------
' フォルダ作成(再帰)
'---------------------
Function func_CreateFolder(strPath As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    On Error Resume Next
    If fso.GetParentFolderName(strPath) <> "" Then
        If fso.FolderExists(fso.GetParentFolderName(strPath)) Then
            If Not (oFS.FolderExists(strPath)) Then
                fso.CreateFolder strPath
            End If
        Else
            func_CreateFolder fso.GetParentFolderName(strPath)
            fso.CreateFolder strPath
        End If
    End If
    If Err.Number = 0 Then
        func_CreateFolder = True
    Else
        func_CreateFolder = False
    End If
    On Error GoTo 0
    Set fso = Nothing
End Function

'----------------------
' excel 転送先Book作成・シート名変更・保存・閉じる
'----------------------
Sub book_add(outFileFullPath As String, outSheetName As String, outExcelFileName As String)
    Application.ScreenUpdating = False              '非表示
    Dim othbook As Workbook
    Dim othsheet As Worksheet
    
    Dim motos As Integer
    
    motos = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1             'Sheet1のみ

    Set othbook = Workbooks.Add
    othbook.SaveAs outFileFullPath                  '保存
    
    Workbooks(outExcelFileName).Activate
    Worksheets(1).Name = outSheetName               'Sheet1 -> シート名　変更
    
    othbook.Save                                    '保存
    othbook.Close SaveChanges:=True
    
    Set othsheet = Nothing
    Set othbook = Nothing
    Application.ScreenUpdating = True               '表示
End Sub

'----------------------
' excel 転送先ファイルにシート追加
'----------------------
Sub sheet_add(outFileFullPath As String, outSheetName As String, outExcelFileName As String)
    Application.ScreenUpdating = False              '非表示
    Dim othbook As Workbook
    Dim othsheet As Worksheet
    
    Set othbook = Workbooks.Open(outFileFullPath)
    
    If Not (func_worksheetexist(othbook, outSheetName)) Then
        Set othsheet = othbook.Worksheets.Add()
        othsheet.Name = outSheetName
        othbook.Save                                '保存
        othbook.Close SaveChanges:=True
    End If
        
    Set othsheet = Nothing
    Set othbook = Nothing
    Application.ScreenUpdating = True               '表示
End Sub


'----------------------
' excel 集計表転送シートの"タイトル"を転送先の１行目に複写する
'----------------------
Sub title_add(this2sheetName As String, outFileFullPath As String, outSheetName As String, outExcelFileName As String)
    Application.ScreenUpdating = False              '非表示
    Dim this2sheet As Worksheet
    Set this2sheet = Worksheets(this2sheetName)
        
    Dim titleCellStr As String
    titleCellStr = "タイトル"
    
    Dim othbook As Workbook
    Dim othsheet As Worksheet
    
    Set othbook = Workbooks.Open(outFileFullPath)
    Set othsheet = Worksheets(outSheetName)
    
    '集計表転送シートから"タイトル"行を取得
    Dim this2Row As Long
    If this2sheet.Columns(1).Find(What:=titleCellStr, lookat:=xlWhole) Is Nothing Then
        MsgBox "集計表転送シート形式エラー  [" & titleCellStr & "]　セルが存在しない[title_add]"
        End
    Else
        this2Row = this2sheet.Columns(1).Find(What:=titleCellStr, lookat:=xlWhole).Row
    End If
    
    '集計表転送シートから"タイトル"列の最終
    Dim this2ColumnEnd As Long
    this2ColumnEnd = this2sheet.Cells(this2Row, this2sheet.Columns.Count).End(xlToLeft).Column
    
    '集計表転送シートの"タイトル"を転送先の１行目に複写する
    this2sheet.Range(this2sheet.Cells(this2Row, 2), this2sheet.Cells(this2Row, this2ColumnEnd)).Copy
    othsheet.Range(othsheet.Cells(1, 1), othsheet.Cells(1, this2ColumnEnd - 1)).PasteSpecial Paste:=xlPasteValues
    
    'タイトル行の末尾に更新日時を追加
    othsheet.Cells(1, this2ColumnEnd).Value = "更新日時"
        
    othbook.Save
    othbook.Close SaveChanges:=True
    
    Set othsheet = Nothing
    Set othbook = Nothing
    Set this2sheet = Nothing
    Application.ScreenUpdating = True               '表示
End Sub

'----------------------
' excel 集計表転送シートの"データ"を転送先へ複写・更新する
'----------------------
Sub data_add(this2sheet As Object, outFileFullPath As String, outSheetName As String, outExcelFileName As String)
    Application.ScreenUpdating = False              '非表示
    Application.DisplayAlerts = False               '確認メッセージ　非表示
    
    Dim titleCellStr As String
    titleCellStr = "タイトル"
        
    Dim othbook As Workbook
    Dim othsheet As Worksheet
    
    Set othbook = Workbooks.Open(outFileFullPath)
    Set othsheet = Worksheets(outSheetName)         '集計シート
    
    '集計表転送シートから"タイトル"行を取得
    Dim this2Row As Long
    If this2sheet.Columns(1).Find(What:=titleCellStr, lookat:=xlWhole) Is Nothing Then
        MsgBox "集計表転送シート形式エラー  [" & titleCellStr & "]　セルが存在しない[data_add]"
        End
    Else
        this2Row = this2sheet.Columns(1).Find(What:=titleCellStr, lookat:=xlWhole).Row
    End If
    
    '集計表転送シートから"タイトル"列の最終
    Dim this2ColumnEnd As Long
    this2ColumnEnd = this2sheet.Cells(this2Row, this2sheet.Columns.Count).End(xlToLeft).Column
    
    '集計表転送シートのデータ行の最終行位置を取得
    Dim this2DataRowEnd As Long
    this2DataRowEnd = this2sheet.Cells(this2sheet.Rows.Count, 2).End(xlUp).Row
    
    '集計シートのデータ行の最終行位置を取得
    Dim othDataRowEnd As Long
    othDataRowEnd = othsheet.Cells(othsheet.Rows.Count, 1).End(xlUp).Row
    
    Dim i As Long
    Dim addCnt As Long
    Dim updCnt As Long
    Dim msgstr As String
    Dim findRow As Long
    
    addCnt = 0
    updCnt = 0
    msgstr = ""
    
    '集計表転送シートのデータ行を転送先の更新 or 末尾に追加
    For i = (this2Row + 1) To this2DataRowEnd
        If this2sheet.Cells(i, 2).Value <> "" Then 'KEYが""は処理しない
            If othsheet.Columns(1).Find(What:=this2sheet.Cells(i, 2), lookat:=xlWhole) Is Nothing Then
               findRow = othsheet.Cells(othsheet.Rows.Count, 1).End(xlUp).Row + 1                      '追加
               addCnt = addCnt + 1
            Else
               findRow = othsheet.Columns(1).Find(What:=this2sheet.Cells(i, 2), lookat:=xlWhole).Row   '更新
               updCnt = updCnt + 1
            End If
        
            this2sheet.Range(this2sheet.Cells(i, 2), this2sheet.Cells(i, this2ColumnEnd)).Copy
            othsheet.Range(othsheet.Cells(findRow, 1), othsheet.Cells(findRow, this2ColumnEnd - 1)).PasteSpecial Paste:=xlPasteValues
            othsheet.Cells(findRow, this2ColumnEnd).Value = "'" & func_GetLocalTime()
        End If
    Next
    
    othbook.Save
    othbook.Close SaveChanges:=True
    
    'メッセージ表示
    If addCnt + updCnt > 0 Then
        If addCnt > 0 Then
            msgstr = "追加:" & addCnt
        End If
        If msgstr <> "" Then
            msgstr = msgstr & vbCrLf
        End If
        If updCnt > 0 Then
            msgstr = msgstr & "更新:" & updCnt
        End If
        MsgBox msgstr
    End If
    
    Set othsheet = Nothing
    Set othbook = Nothing
    Set this2sheet = Nothing
    Application.CutCopyMode = False                      'コピーエリア選択解除
    Application.DisplayAlerts = True                     '確認メッセージ　表示
    Application.ScreenUpdating = True                    '表示
End Sub

保存時にデータ転送を起動するマクロです。

これは、「ThisWorkbook」に記述します

Private Sub Workbook_BeforeSave(ByVal saveasui As Boolean, cancel As Boolean)
    Call Module1.button1_Click
End Sub

#マクロ説明
###時刻を　2020/05/22 19:30:37.175　の形式で返します。
集計表の行追加、更新の時刻として使用します。

getlocaltime

Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)

Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Function func_GetLocalTime() As String
    Dim t   As SYSTEMTIME
    Call GetLocalTime(t)                ' 現在日時取得 -> yyyy/mm/dd hh:mm:ss.fff
    func_GetLocalTime = Format(t.wYear, "0000") & "/" & Format(t.wMonth, "00") & "/" & Format(t.wDay, "00") _
    & " " & Format(t.wHour, "00") & ":" & Format(t.wMinute, "00") & ":" & Format(t.wSecond, "00") _
    & "." & Format(t.wMilliseconds, "000")
End Function

###「集計表転送ボタン」クリックで起動します。
１．集計表転送シートの保存先設定をチェックします。
２．保存先が無ければ作成します。
３．転送先へ追加・更新します。

button1_click

'---------------------
' 主処理
'---------------------
Sub button1_Click()
    Dim outFolderName As String
    Dim outExcelFileName As String
    Dim outFileFullPath As String
    Dim outSheetName As String
    Dim this2sheet As Worksheet
    Dim oFS As Object
    
    Set oFS = CreateObject("Scripting.FileSystemObject")
    Set this2sheet = Sheets("集計表転送")
    
    On Error Resume Next
    outFolderName = oFS.GetAbsolutePathName(this2sheet.Range("B2").Value)
    If Err.Number <> 0 Then
        MsgBox "転送先フォルダ[" & this2sheet.Range("B2").Value & "]不正"
        End
    End If
    
    If func_sheetNameCheck(this2sheet.Range("B3").Value) = False Then
        MsgBox "転送先ファイル名[" & this2sheet.Range("B3").Value & "]不正1"
        End
    End If
    outExcelFileName = oFS.GetFileName(oFS.GetAbsolutePathName(this2sheet.Range("B3").Value))
    If Err.Number <> 0 Then
        MsgBox "転送先ファイル名[" & this2sheet.Range("B3").Value & "]不正2"
        End
    End If
    If oFS.GetBaseName(outExcelFileName) = "" Then
        MsgBox "転送先ファイル名[" & this2sheet.Range("B3").Value & "]不正3"
        End
    End If
    On Error GoTo 0
    
    outFileFullPath = outFolderName & "\" & outExcelFileName
    
    outSheetName = this2sheet.Range("B4").Value
    If func_sheetNameCheck(outSheetName) = False Then
        MsgBox "シート名[" & outSheetName & "]不正"
        End
    End If
    
    If Not (oFS.FolderExists(outFolderName)) Then   '転送先フォルダ存在確認 & 無ければ作成 & 作成失敗 → 終了
        Call func_CreateFolder(outFolderName)
    End If
    If Not (oFS.FolderExists(outFolderName)) Then
        MsgBox "転送先フォルダ[" & outFolderName & "]作成不能、手作業で作成してください"
        End
    End If

    '転送先ファイル存在確認 & 無ければ作成
    If oFS.FileExists(outFileFullPath) Then
        If Not (func_worksheetexist(Workbooks.Open(outFileFullPath), outSheetName)) Then        'シートが存在しない
            Call sheet_add(outFileFullPath, outSheetName, outExcelFileName)                     '転送先シート作成
            Call title_add(this2sheet.Name, outFileFullPath, outSheetName, outExcelFileName)    '転送先ファイルタイトル作成
        End If
    Else
       '転送先ファイル存在しない
       Call book_add(outFileFullPath, outSheetName, outExcelFileName)                           '転送先ファイル&シート作成
       Call title_add(this2sheet.Name, outFileFullPath, outSheetName, outExcelFileName)         '転送先ファイルタイトル作成
    End If
    
    'データ転送
    Call data_add(this2sheet, outFileFullPath, outSheetName, outExcelFileName)                  '転送先ファイルタイトル作成
    
    Set this2sheet = Nothing
    Set oFS = Nothing
End Sub

worksheet名チェック

使えない文字の存在チェック簡易版

sheetNameCheck

'---------------------
' worksheet名チェック
'---------------------
Function func_sheetNameCheck(checkSheetName As String)
    func_sheetNameCheck = False
    Dim buf As String
    Dim c As Variant
    buf = Range("A1")
    If checkSheetName = "" Then Exit Function            '(1)空欄
    If Len(checkSheetName) > 31 Then Exit Function       '(3)文字数が31文字以内
    For Each c In Array(":", "\", "/", "?", "*", "[", "]", "<", ">", "|")  '(2)不正な文字
        If InStr(checkSheetName, c) > 0 Then Exit Function
    Next
    func_sheetNameCheck = True
End Function

worksheet存在判定

ワークシートの存在チェック

worksheetexist

'---------------------
' worksheet名存在判定
'---------------------
Function func_worksheetexist(checkWorkbook As Object, workSheetName As String)
    func_worksheetexist = False
    Dim stobj As Object
    For Each stobj In checkWorkbook.Sheets
        If stobj.Name = workSheetName Then
            func_worksheetexist = True
            Exit For
        End If
    Next
End Function

保存先フォルダを作成

フォルダが無ければ作成します。再帰処理しています。異常に深いディレクトリだと、エラーが発生するはず。

CreateFolder

'---------------------
' フォルダ作成(再帰)
'---------------------
Function func_CreateFolder(strPath As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    On Error Resume Next
    If fso.GetParentFolderName(strPath) <> "" Then
        If fso.FolderExists(fso.GetParentFolderName(strPath)) Then
            If Not (oFS.FolderExists(strPath)) Then
                fso.CreateFolder strPath
            End If
        Else
            func_CreateFolder fso.GetParentFolderName(strPath)
            fso.CreateFolder strPath
        End If
    End If
    If Err.Number = 0 Then
        func_CreateFolder = True
    Else
        func_CreateFolder = False
    End If
    On Error GoTo 0
    Set fso = Nothing
End Function

転送先Book、sheetを作成

転送先Bookとsheetを作成します。

book_add

'----------------------
' excel 転送先Book作成・シート名変更・保存・閉じる
'----------------------
Sub book_add(outFileFullPath As String, outSheetName As String, outExcelFileName As String)
    Application.ScreenUpdating = False              '非表示
    Dim othbook As Workbook
    Dim othsheet As Worksheet
    
    Dim motos As Integer
    
    motos = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1             'Sheet1のみ

    Set othbook = Workbooks.Add
    othbook.SaveAs outFileFullPath                  '保存
    
    Workbooks(outExcelFileName).Activate
    Worksheets(1).Name = outSheetName               'Sheet1 -> シート名　変更
    
    othbook.Save                                    '保存
    othbook.Close SaveChanges:=True
    
    Set othsheet = Nothing
    Set othbook = Nothing
    Application.ScreenUpdating = True               '表示
End Sub

sheetを作成

sheetを作成します。

sheet_add

'----------------------
' excel 転送先ファイルにシート追加
'----------------------
Sub sheet_add(outFileFullPath As String, outSheetName As String, outExcelFileName As String)
    Application.ScreenUpdating = False              '非表示
    Dim othbook As Workbook
    Dim othsheet As Worksheet
    
    Set othbook = Workbooks.Open(outFileFullPath)
    
    If Not (func_worksheetexist(othbook, outSheetName)) Then
        Set othsheet = othbook.Worksheets.Add()
        othsheet.Name = outSheetName
        othbook.Save                                '保存
        othbook.Close SaveChanges:=True
    End If
        
    Set othsheet = Nothing
    Set othbook = Nothing
    Application.ScreenUpdating = True               '表示
End Sub

集計表転送シートの"タイトル"を転送先の１行目に複写する

末尾に更新日時を追加します
「タイトル」(A5)セルの右隣セル(A6)をタイトルの始まりとしています。

title_add

'----------------------
' excel 集計表転送シートの"タイトル"を転送先の１行目に複写する
'----------------------
Sub title_add(this2sheetName As String, outFileFullPath As String, outSheetName As String, outExcelFileName As String)
    Application.ScreenUpdating = False              '非表示
    Dim this2sheet As Worksheet
    Set this2sheet = Worksheets(this2sheetName)
        
    Dim titleCellStr As String
    titleCellStr = "タイトル"
    
    Dim othbook As Workbook
    Dim othsheet As Worksheet
    
    Set othbook = Workbooks.Open(outFileFullPath)
    Set othsheet = Worksheets(outSheetName)
    
    '集計表転送シートから"タイトル"行を取得
    Dim this2Row As Long
    If this2sheet.Columns(1).Find(What:=titleCellStr, lookat:=xlWhole) Is Nothing Then
        MsgBox "集計表転送シート形式エラー  [" & titleCellStr & "]　セルが存在しない[title_add]"
        End
    Else
        this2Row = this2sheet.Columns(1).Find(What:=titleCellStr, lookat:=xlWhole).Row
    End If
    
    '集計表転送シートから"タイトル"列の最終
    Dim this2ColumnEnd As Long
    this2ColumnEnd = this2sheet.Cells(this2Row, this2sheet.Columns.Count).End(xlToLeft).Column
    
    '集計表転送シートの"タイトル"を転送先の１行目に複写する
    this2sheet.Range(this2sheet.Cells(this2Row, 2), this2sheet.Cells(this2Row, this2ColumnEnd)).Copy
    othsheet.Range(othsheet.Cells(1, 1), othsheet.Cells(1, this2ColumnEnd - 1)).PasteSpecial Paste:=xlPasteValues
    
    'タイトル行の末尾に更新日時を追加
    othsheet.Cells(1, this2ColumnEnd).Value = "更新日時"
        
    othbook.Save
    othbook.Close SaveChanges:=True
    
    Set othsheet = Nothing
    Set othbook = Nothing
    Set this2sheet = Nothing
    Application.ScreenUpdating = True               '表示
End Sub

データを転送します

「タイトル」(A5)セルの右隣左下セル(A7)をデータの始まりとしています。
データの先頭セル(KEY)が同じものは更新、同じものが無ければ、末尾に追加します。
少し長いのですが

data_add

'----------------------
' excel 集計表転送シートの"データ"を転送先へ複写・更新する
'----------------------
Sub data_add(this2sheet As Object, outFileFullPath As String, outSheetName As String, outExcelFileName As String)
    Application.ScreenUpdating = False              '非表示
    Application.DisplayAlerts = False               '確認メッセージ　非表示
    
    Dim titleCellStr As String
    titleCellStr = "タイトル"
        
    Dim othbook As Workbook
    Dim othsheet As Worksheet
    
    Set othbook = Workbooks.Open(outFileFullPath)
    Set othsheet = Worksheets(outSheetName)         '集計シート
    
    '集計表転送シートから"タイトル"行を取得
    Dim this2Row As Long
    If this2sheet.Columns(1).Find(What:=titleCellStr, lookat:=xlWhole) Is Nothing Then
        MsgBox "集計表転送シート形式エラー  [" & titleCellStr & "]　セルが存在しない[data_add]"
        End
    Else
        this2Row = this2sheet.Columns(1).Find(What:=titleCellStr, lookat:=xlWhole).Row
    End If
    
    '集計表転送シートから"タイトル"列の最終
    Dim this2ColumnEnd As Long
    this2ColumnEnd = this2sheet.Cells(this2Row, this2sheet.Columns.Count).End(xlToLeft).Column
    
    '集計表転送シートのデータ行の最終行位置を取得
    Dim this2DataRowEnd As Long
    this2DataRowEnd = this2sheet.Cells(this2sheet.Rows.Count, 2).End(xlUp).Row
    
    '集計シートのデータ行の最終行位置を取得
    Dim othDataRowEnd As Long
    othDataRowEnd = othsheet.Cells(othsheet.Rows.Count, 1).End(xlUp).Row
    
    Dim i As Long
    Dim addCnt As Long
    Dim updCnt As Long
    Dim msgstr As String
    Dim findRow As Long
    
    addCnt = 0
    updCnt = 0
    msgstr = ""
    
    '集計表転送シートのデータ行を転送先の更新 or 末尾に追加
    For i = (this2Row + 1) To this2DataRowEnd
        If this2sheet.Cells(i, 2).Value <> "" Then 'KEYが""は処理しない
            If othsheet.Columns(1).Find(What:=this2sheet.Cells(i, 2), lookat:=xlWhole) Is Nothing Then
               findRow = othsheet.Cells(othsheet.Rows.Count, 1).End(xlUp).Row + 1                      '追加
               addCnt = addCnt + 1
            Else
               findRow = othsheet.Columns(1).Find(What:=this2sheet.Cells(i, 2), lookat:=xlWhole).Row   '更新
               updCnt = updCnt + 1
            End If
        
            this2sheet.Range(this2sheet.Cells(i, 2), this2sheet.Cells(i, this2ColumnEnd)).Copy
            othsheet.Range(othsheet.Cells(findRow, 1), othsheet.Cells(findRow, this2ColumnEnd - 1)).PasteSpecial Paste:=xlPasteValues
            othsheet.Cells(findRow, this2ColumnEnd).Value = "'" & func_GetLocalTime()
        End If
    Next
    
    othbook.Save
    othbook.Close SaveChanges:=True
    
    'メッセージ表示
    If addCnt + updCnt > 0 Then
        If addCnt > 0 Then
            msgstr = "追加:" & addCnt
        End If
        If msgstr <> "" Then
            msgstr = msgstr & vbCrLf
        End If
        If updCnt > 0 Then
            msgstr = msgstr & "更新:" & updCnt
        End If
        MsgBox msgstr
    End If
    
    Set othsheet = Nothing
    Set othbook = Nothing
    Set this2sheet = Nothing
    Application.CutCopyMode = False                      'コピーエリア選択解除
    Application.DisplayAlerts = True                     '確認メッセージ　表示
    Application.ScreenUpdating = True                    '表示
End Sub

物忘れ防止集計転送.xlsm
https://github.com/sugita0301/douzo