VBA：更新日比較によるファイル読み込み実行有無の実装

Question

実現したいこと

特定のフォルダに格納されているExcelファイルの特定のセルを読み込んで、別ファイルの一覧表Excelに転記。
格納されているファイルのフォーマットはすべて同じ前提。

初回読み込み後、ファイルの更新日が新しくなっているものは再読み込みを行い、転記済の情報を上書きする。
更新日が同じもの（新しくなっていないもの）は読み込まない。

前提

VBAで以下コードを実装済

Sub AppendDataToExistingFile()
    Dim TargetFilePath As String
    Dim TargetWorkbook As Workbook
    Dim TargetSheet As Worksheet
    Dim SourceFolder As String
    Dim SourceFile As String
    Dim SourceFileUpdateDate As Date
    Dim NextRow As Long
    
    ' 抽出元のフォルダパス
    SourceFolder = "C:\Users\aaaaaaaaaaaaaaa\OneDrive\デスクトップ\test\"
    
    ' 既存のExcelファイルパス
    TargetFilePath = "C:\Users\aaaaaaaaaaaaaaa\OneDrive\デスクトップ\test.xlsm"
    
    ' 既存のExcelファイル
    Set TargetWorkbook = Workbooks.Open(TargetFilePath)
    
    ' 追記するシートを選択（1番目のシート）
    Set TargetSheet = TargetWorkbook.Sheets(1)
    
    ' 最終行を特定す
    NextRow = TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Row + 1
    
    ' 抽出元のフォルダ内のExcelファイルを走査
    SourceFile = Dir(SourceFolder & "*.xlsx")
    
    Do While SourceFile <> ""
        ' 抽出元ファイルの更新日を取得す
        SourceFileUpdateDate = FileDateTime(SourceFolder & SourceFile)
        
        ' 更新日の比較
        If SourceFileUpdateDate > TargetSheet.Cells(NextRow, 7).Value Then
            ' 更新日が新しい場合のみデータを読み込む
            Call ImportDataFromSourceFile(SourceFolder & SourceFile, TargetSheet, NextRow)
            NextRow = NextRow + 1
        End If
        
        ' 次のファイルを取得
        SourceFile = Dir
    Loop
    
    ' 既存のExcelファイルを保存
    TargetWorkbook.Save
    
    ' 既存のExcelファイルを閉る
    TargetWorkbook.Close SaveChanges:=False
    
    ' 完了メッセージを表示
    MsgBox "データの追記が完了しました。", vbInformation
End Sub

Sub ImportDataFromSourceFile(SourceFilePath As String, TargetSheet As Worksheet, NextRow As Long)
    Dim SourceWorkbook As Workbook
    Dim SourceSheet As Worksheet
    Dim SourceValue1 As Variant
    Dim SourceValue2 As Variant
    Dim SourceText1 As String
    Dim SourceText2 As String
    Dim SourceText3 As String
    Dim SourceRange As Range
    Dim SourceText4 As String
    Dim PasteRangeValue As Range
    
    ' 抽出元のExcelファイルを開く
    Set SourceWorkbook = Workbooks.Open(SourceFilePath)
    Set SourceSheet = SourceWorkbook.Sheets(3) ' 抽出元のシートを指定（3番目）
    
    ' セル１の抽出
    SourceValue1 = SourceSheet.Range("W2:Z2").Value
    ' セル２の抽出
    SourceValue2 = SourceSheet.Range("W3:Z3").Value
    ' セル３の抽出
    SourceText1 = SourceSheet.Range("W43").Value
    ' セル４の抽出
    SourceText2 = SourceSheet.Range("B8").Value
    ' セル５の抽出
    SourceText3 = SourceSheet.Range("B15").Value
    ' セル６の抽出
    Set SourceRange = SourceSheet.Range("U40:Z40")
    ' 更新日の抽出
    SourceText4 = Format(FileDateTime(SourceFilePath), "yyyy/mm/dd hh:mm:ss")
    
    ' データの書き込み
    TargetSheet.Cells(NextRow, 1).Value = SourceFilePath
    ' セル１の転記
    TargetSheet.Cells(NextRow, 2).Value = SourceValue1
    ' セル２の転記
    TargetSheet.Cells(NextRow, 3).Value = SourceValue2
    ' セル３の転記
    TargetSheet.Cells(NextRow, 4).Value = SourceText1
    ' セル４の転記
    TargetSheet.Cells(NextRow, 5).Value = SourceText2
    ' セル５の転記
    TargetSheet.Cells(NextRow, 6).Value = SourceText3
    ' 更新日の転記
    TargetSheet.Cells(NextRow, 7).Value = SourceText4
    
    ' セル６の転記
    Set PasteRangeValue = TargetSheet.Cells(NextRow, 8)
    PasteRangeValue.Resize(1, SourceRange.Columns.Count).Value = SourceRange.Value
    
    ' 抽出元のファイルを閉じます
    SourceWorkbook.Close SaveChanges:=False
End Sub

発生している問題・エラーメッセージ

更新日の新旧にかかわらずすべてのファイルを何度も読み込んでしまいます。

該当のソースコード

上記の通り

試したこと

更新日の比較方法等をいくつか試しましたがNGでした。

Answer 1

下記のようにしてはどうでしょうか。

Sub AppendDataToExistingFile()
..
...略...
..

    
    Do While SourceFile <> ""
        ' 抽出元ファイルの更新日を取得する。
        SourceFileUpdateDate = FileDateTime(SourceFolder & SourceFile)
        ' ファイル名を調べて、すでに記録済みのファイルかどうかを調べる。
        Dim FoundCell As Range
        Set FoundCell = TargetSheet.Columns(1).Find(What:=SourceFolder & SourceFile, LookIn:=xlValues, LookAt:=xlWhole)
        
        ' 記録済みのファイルである場合：
        If Not FoundCell Is Nothing Then
            ' 記録されている更新日と、現在の更新日を比較
            If SourceFileUpdateDate > FoundCell.Offset(0, 6).Value Then
                ' 更新日が新しい場合のみデータを読み込む
                Call ImportDataFromSourceFile(SourceFolder & SourceFile, TargetSheet, FoundCell.Row)
            End If
        Else
            ' 新しいファイルなのでデータを追加する。
            Call ImportDataFromSourceFile(SourceFolder & SourceFile, TargetSheet, NextRow)
            NextRow = NextRow + 1
        End If
        
        ' 次のファイルを取得
        SourceFile = Dir
    Loop
    
...以下略...

End Sub

上のコードでは、まず抽出元からファイルを1つずつ読み込んだときに
そのファイルが既存のExcelの記録中に存在するか判定しています。

存在する場合は、更新日を比較して、更新日が新しければ、データを読み込み、記録行を更新します。
存在しない場合は、もともとのコードの通り、データを最下行（の1つ下）に追加するだけです。

Comments

[juska]

ありがとうございました！
下記コードに修正したところ希望通り実装できました。

-----------
Sub AppendDataToExistingFile()
Dim TargetFilePath As String
Dim TargetWorkbook As Workbook
Dim TargetSheet As Worksheet
Dim SourceFolder As String
Dim SourceFile As String
Dim SourceFileUpdateDate As Date
Dim NextRow As Long

' 抽出元のフォルダパス
SourceFolder = "C:\Users\aaaaaaaaaaaaaaaaa\OneDrive\デスクトップ\test\"

' 既存のExcelファイルパス
TargetFilePath = "C:\Users\aaaaaaaaaaaaaaaaa\OneDrive\デスクトップ\test.xlsm"

' 既存のExcelファイル
Set TargetWorkbook = Workbooks.Open(TargetFilePath)

' 追記するシートを選択（1番目のシート）
Set TargetSheet = TargetWorkbook.Sheets(1)

' 最終行を特定す
NextRow = TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Row + 1

' 抽出元のフォルダ内のExcelファイルを走査
SourceFile = Dir(SourceFolder & "*.xlsx")

' 初回書き込み位置を4行目に設定
NextRow = 4

Do While SourceFile <> ""
' 抽出元ファイルの更新日を取得する。
SourceFileUpdateDate = FileDateTime(SourceFolder & SourceFile)
' ファイル名を調べて、すでに記録済みのファイルかどうかを調べる。
Dim FoundCell As Range
Set FoundCell = TargetSheet.Columns(1).Find(What:=SourceFolder & SourceFile, LookIn:=xlValues, LookAt:=xlWhole)

' 記録済みのファイルである場合：
If Not FoundCell Is Nothing Then
' 記録されている更新日と、現在の更新日を比較 　　※更新日のセルに修正
If SourceFileUpdateDate > FoundCell.Offset(0, 2).Value Then
' 更新日が新しい場合のみデータを読み込む
Call ImportDataFromSourceFile(SourceFolder & SourceFile, TargetSheet, FoundCell.Row)
End If
Else
' 新しいファイルなのでデータを追加する。
Call ImportDataFromSourceFile(SourceFolder & SourceFile, TargetSheet, NextRow)
NextRow = NextRow + 1
End If

' 次のファイルを取得
SourceFile = Dir
Loop

' 既存のExcelファイルを保存
TargetWorkbook.Save

' 既存のExcelファイルを閉る
TargetWorkbook.Close SaveChanges:=False

' 完了メッセージを表示
MsgBox "データの追記が完了しました。", vbInformation
End Sub

Sub ImportDataFromSourceFile(SourceFilePath As String, TargetSheet As Worksheet, NextRow As Long)
Dim SourceWorkbook As Workbook
Dim SourceSheet As Worksheet
Dim SourceValue1 As Variant
Dim SourceValue2 As Variant
Dim SourceText1 As String
Dim SourceText2 As String
Dim SourceText3 As String
Dim SourceRange As Range
Dim SourceText4 As String
Dim PasteRangeValue As Range

' 抽出元のExcelファイルを開く
Set SourceWorkbook = Workbooks.Open(SourceFilePath)
Set SourceSheet = SourceWorkbook.Sheets(3) ' 抽出元のシートを指定（3番目）

' セル１の抽出
SourceValue1 = SourceSheet.Range("W2:Z2").Value
' セル２の抽出
SourceValue2 = SourceSheet.Range("W3:Z3").Value
' セル３の抽出
SourceText1 = SourceSheet.Range("W43").Value
' セル４の抽出
SourceText2 = SourceSheet.Range("B8").Value
' セル５の抽出
SourceText3 = SourceSheet.Range("B15").Value
' セル６の抽出
Set SourceRange = SourceSheet.Range("U40:Z40")
' 更新日の抽出
SourceText4 = Format(FileDateTime(SourceFilePath), "yyyy/mm/dd hh:mm:ss")

' データの書き込み
TargetSheet.Cells(NextRow, 1).Value = SourceFilePath
' セル１の転記
TargetSheet.Cells(NextRow, 3).Value = SourceValue1
' セル２の転記
TargetSheet.Cells(NextRow, 4).Value = SourceValue2
' セル３の転記
TargetSheet.Cells(NextRow, 5).Value = SourceText1
' セル４の転記
TargetSheet.Cells(NextRow, 6).Value = SourceText2
' セル５の転記
TargetSheet.Cells(NextRow, 7).Value = SourceText3
' 更新日の転記
TargetSheet.Cells(NextRow, 2).Value = SourceText4

' セル６の転記
Set PasteRangeValue = TargetSheet.Cells(NextRow, 8)
PasteRangeValue.Resize(1, SourceRange.Columns.Count).Value = SourceRange.Value

' 抽出元のファイルを閉じます
SourceWorkbook.Close SaveChanges:=False
End Sub