#複数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