Hallo Flo,

habe heute einige Tests durchgeführt. Nur wenige waren erfolgreich.

Die reine Excel Lösung schaut so aus:

Sub AdjustmentData()
    Dim wsh As Worksheet, wshSearch As Worksheet, wsh3 As Worksheet
    Dim rngSearch As Range
    Dim datDate As Date, datDateResult As Date
    Dim sGroup As String, sProd As String
    Dim rng As Range, rngResult As Range
    Dim wbk1 As Workbook
    Dim wbk2 As Workbook
    Set wbk1 = GetWorkbook(ThisWorkbook.Path & "\Datei1.xlsx")
    Set wbk2 = GetWorkbook(ThisWorkbook.Path & "\Datei2.xlsx")
    Set wsh = wbk1.Worksheets(1)
    Set wshSearch = wbk2.Worksheets(1)
    
    Set wsh3 = ThisWorkbook.Worksheets(1)
    
    ' wsh nach Tabelle3 kopieren
    wsh3.UsedRange.EntireRow.Delete
    wsh.UsedRange.Copy
    wsh3.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wsh3.Range("A1").Select
    wbk1.Close True
    Set rngSearch = wshSearch.UsedRange
    Application.ScreenUpdating = False
    For Each rng In wsh3.UsedRange.Rows
        If rng.Row > 1 Then
            datDate = rng.Cells(1, 1).Value
            sProd = rng.Cells(1, 3).Value
            If wshSearch.FilterMode Then
                rngSearch.AutoFilter
            End If
            rngSearch.AutoFilter Field:=4, Criteria1:=sProd
            rngSearch.AutoFilter Field:=36, Criteria1:="=AA", Operator:=xlOr, Criteria2:="=AB"
            For Each rngResult In rngSearch.SpecialCells(xlCellTypeVisible).Rows
                If rngResult.Row > 1 Then
                    datDateResult = rngResult.Cells(1, 46).Value + rngResult.Cells(1, 47).Value
                    If datDate <= DateAdd("s", 3600, datDateResult) And datDate >= DateAdd("s", -3600, datDateResult) Then
                        rng.Cells(1, 5).Value = datDateResult
                    End If
                End If
            Next
            If wshSearch.FilterMode Then
                rngSearch.AutoFilter
            End If
            VBA.DoEvents
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Private Function GetWorkbook(sFilename As String) As Workbook
    Dim wbk As Workbook
    For Each wbk In Application.Workbooks
        If LCase(wbk.FullName) = LCase(sFilename) Then
            Set GetWorkbook = wbk
            Exit Function
        End If
    Next
    Set GetWorkbook = Application.Workbooks.Open(sFilename)
End Function

Bei dieser LÖsung werden die Excel-Dateien Datei1.xlsx und Datei2.xlsx eingelesen.

Die Funktion GetWorkbook lädt bei Bedarf die gewünschte Arbeitsmappe nach, falls diese nicht bereits geöffnet ist.

-------

Wie zuvor angegeben, kann Access mit großen Datenmengen wesentlich performanter umgehen.

In Excel wurde ein Test mit "Microsoft ActiveX Data Objcts 6.0 Library" durchgeführt:

Option Explicit

Private Enum myErrorState
    FileNotFound = -2
    ConnectionError = -1
    Ready = 0
End Enum

Private Sub Zusammenfuehren()
    Dim wbkNew As Workbook
    Dim wsh As Worksheet, wshTbl1 As Worksheet, wshTbl2 As Worksheet
    Dim wshOut As Worksheet
    Set wbkNew = GetWorkbook(ThisWorkbook.Path & "\Datei1.xlsx")

    Set wsh = wbkNew.Worksheets(1)
    wsh.UsedRange.Copy
    Set wshTbl1 = ThisWorkbook.Worksheets.Add
    wshTbl1.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    SetNames wshTbl1.UsedRange, "Daten1"
    
    Set wbkNew = GetWorkbook(ThisWorkbook.Path & "\Datei2.xlsx")
    
    Set wsh = wbkNew.Worksheets(1)
    wsh.UsedRange.Copy
    Set wshTbl2 = ThisWorkbook.Worksheets.Add
    wshTbl2.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    SetNames wshTbl2.UsedRange, "Daten2"
    
    
    Dim ad As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim bErr1 As myErrorState
    Dim strSQL As String
    
    Set ad = GetConnection(ThisWorkbook.FullName, bErr1)
    
    Set rs = New ADODB.Recordset
    
    strSQL = "SELECT Quelle1.[Datum Uhrzeit], Quelle1.F2, Quelle1.Produktcode, Filter.DatumUhrzeit FROM (SELECT Daten1.[Datum Uhrzeit], Daten1.Produktcode, myDaten2.DatumUhrzeit FROM Daten1 INNER JOIN (Select *, [Datum]+[Uhrzeit] as DatumUhrzeit from Daten2)  AS myDaten2 ON Daten1.Produktcode = myDaten2.Produktcode WHERE (((Abs(DateDiff(""s"",[DatumUhrzeit],[Datum Uhrzeit])))<=3600) AND ((myDaten2.Gruppenbezeichnung)=""AA"")) OR (((Abs(DateDiff(""s"",[DatumUhrzeit],[Datum Uhrzeit])))<=3600) AND ((myDaten2.Gruppenbezeichnung)=""AB"")))  AS Filter RIGHT JOIN Daten1 AS Quelle1 ON Filter.Produktcode = Quelle1.Produktcode"

'    strSQL = "Select * from Daten1"
    
    rs.Open strSQL, ad, adOpenDynamic, adLockOptimistic
    
    With ThisWorkbook
        Set wshOut = .Worksheets("Tabelle3")
        wshOut.Range(wshOut.Range("A2"), wshOut.Range("A2").End(xlDown)).EntireRow.Delete
        wshOut.Range("A2:D2").CopyFromRecordset rs
    End With
    
    rs.Close
    ad.Close
    
    Application.DisplayAlerts = False
    wshTbl1.Delete
    wshTbl2.Delete
    Application.DisplayAlerts = True
End Sub

Private Function GetWorkbook(sFilename As String) As Workbook
    Dim wbk As Workbook
    For Each wbk In Application.Workbooks
        If LCase(wbk.FullName) = LCase(sFilename) Then
            Set GetWorkbook = wbk
            Exit Function
        End If
    Next
    Set GetWorkbook = Application.Workbooks.Open(sFilename)
End Function

Private Sub SetNames(rng As Range, sName As String)
    Dim wsh As Worksheet
    Dim wbk As Workbook
    Dim Nm As Name
    
    Set wsh = rng.Parent
    Set wbk = wsh.Parent

    For Each Nm In wsh.Names
        If Nm.Name = sName Then
            Nm.Delete
            Exit For
        End If
    Next
    For Each Nm In wbk.Names
        If Nm.Name = sName Then
            Nm.Delete
            Exit For
        End If
    Next
    wbk.Names.Add Name:=sName, RefersTo:=rng
End Sub

Private Function GetConnection(ByVal sFilename As String, ByRef bError As myErrorState) As ADODB.Connection
    On Error GoTo Err_Handler
    Dim sTable As String
    Dim ad As ADODB.Connection

    Dim wbk As Workbook
    
    bError = myErrorState.Ready
    Set wbk = GetWorkbook(sFilename)
    
    If Not wbk Is Nothing Then
        Set ad = New ADODB.Connection
        ad.CursorLocation = adUseClient
        ad.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Extended Properties=Excel 8.0;" & _
        "Data Source=" & wbk.FullName & ";"
    Else
        bError = myErrorState.FileNotFound
    End If
    Set GetConnection = ad
Err_Exit:
    Exit Function
Err_Handler:
    bError = myErrorState.ConnectionError
    err.Clear
    Resume Err_Exit
End Function

Der Befehl "Zusammenfuehren" startet den Vorgang.

Dabei werden die Tabellen der biden Arbeitsmappen importiert, ausgewertet, die Ergebnisse in die Tabelle eingestellt und anschließend die zuvor importierten Tabellen wieder entfernt.

Der Select-Befehl liefert allerdings falsche Ergebnisse. Ursache belang unbekannt.

Der Select-Befehl wird innerhalb von wenigen Sekunden ausgeführt.

Nun zur Access Lösung

In dieser Access-DB werden die Areitsmappen Datei1.xlsx und Datei2.xlsx verknüpft eingelesen und in der View qryFilter ausgewertet.

Vor dem Ausführen muss der Pfad zu den Arbeitsmappe angepasst werden.

Die View qryFilter wird auch innerhalb von wenigen Sekunden ausgelesen und zeigt meines Wissens korrekte Daten an.

Die Ergebnisse können auch als Excel-Arbeitsmappe exportiert werden.

LG, Ben