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"
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