Kompliziertes Makro - Ergänzung

Option Explicit
Public Const sDBName = "D:\170109_KPI_Schichten_Hattorf"
Public Const sData = "Basisdaten"
Public Const sQueryName = "Abf_43_Bewegungen_und_Zeiten_ALLE"
Public Const iFieldDate = 0   'Spalte Accessdantenbank Spalte 0
Public Const iFieldShift = 1  'Spalte Accessdantenbank Spalte 1
Public Const iProcess = 3     'Spalte Accessdantenbank Spalte 3
Public Const iProcess_T8 = 2   'Spalte Accessdantenbank Spalte 2
Public Const iFieldA4TRLG = 7   'Spalte Accessdantenbank Spalte 7
Public Const iFieldA4TZAK = 9   'Spalte Accessdantenbank Spalte 9
Public Const sShift1 = "Fruehschicht"
Public Const sShift2 = "Spaetschicht"
Public Const sShift3 = "Nachtschicht"
Sub ImportAccessData(arrQuery As Variant, Optional dFromDate As Date, Optional dToDate As Date,  _
_
Optional sDBName As String, Optional bolAutomatic As Boolean)
Dim wsTarget As Worksheet
Dim objAcc As Object, dbHattdorf As Object, _
qryTarget As Object, rsData As Object, objDict As Object
Dim iDate As Integer, iFields As Integer, iShift As Integer, _
iFieldCount As Integer, i As Integer, iDict As Integer
Dim arrTmp() As Variant, arrFields() As Variant, arrShift() As Variant
Dim dStart As Date, tmpDate As Date
Dim sQuery As String
Dim dbRecCount As Double
Dim cTDate As Range
Dim varKey As Variant, varDict As Variant
Dim tmpShift As Integer, iTRow As Integer, iTColTime As Integer, _
iTColQty As Integer, iDataModel As Integer, iTColEmp As Integer, _
iOffset As Integer, iCount As Integer, iUF As Integer, _
iDateCount As Integer, iTColTimeZAK As Integer, _
iOffsetZAK
If arrQuery(0) = 0 Then GoTo ErrHandler
Unload frmSelectImport
If dFromDate = 0 Or dToDate = 0 Then
dFromDate = Date - 7
dToDate = Date
End If
If sDBName = "" Then
sDBName = GetFile
If sDBName = "" Then Exit Sub
End If
On Error GoTo ErrHandler
Set objAcc = CreateObject("Access.Application")
Set wsTarget = ThisWorkbook.Worksheets(sData)
OpenNewDB:
Set dbHattdorf = objAcc.DBEngine.OpenDatabase(sDBName, False, False)
Set qryTarget = dbHattdorf.QueryDefs(arrQuery(0))
Set objDict = CreateObject("Scripting.Dictionary")
If arrQuery(1) = True And arrQuery(2) = True Then
arrFields() = Array(2, 3, 4, 5, 6, iFieldA4TRLG, iFieldA4TZAK) ' Habe hier einfach hinten   _
_
iFieldA4TZAK ergänzt
iFieldCount = UBound(arrFields()) + 1
Debug.Print iFieldCount
arrShift = Array(sShift1, sShift2, sShift3)
sQuery = "GLT Lager + Reifen T8"
Else
Exit Sub
End If
ReDim arrTmp(0 To iFieldCount - 1)
With dbHattdorf
Call ConnectSQL(dbHattdorf, "dbo_PZWDTA640_V_HATTORF", "PZWDTA640", "a4t_aus", "tx345k", "  _
_
RES-SQL01")
Call ConnectSQL(dbHattdorf, "dbo_Einlagerungen_VIEW", "kpi_aus", "kpi", "kpi", "RES-SQL03")
Call ConnectSQL(dbHattdorf, "dbo_Auslagerungen_VIEW", "kpi_aus", "kpi", "kpi", "RES-SQL03")
End With
With qryTarget
.Parameters!AB_Datum = dFromDate
.Parameters!BIS_Datum = dToDate
'Application.Wait (2000)
DoEvents
Set rsData = .OpenRecordset
End With
With rsData
Application.ScreenUpdating = False
If .EOF Then
ThisWorkbook.Activate
MsgBox "Die Abfrage '" & arrQuery(0) & "' enthält keine Datensätze!", vbInformation +   _
_
vbOKOnly, "Datenabfrage in Microsoft Access"
GoTo EndQuery
Else
.MoveLast
dbRecCount = .RecordCount
.MoveFirst
End If
Do Until .EOF
varKey = Application.WorksheetFunction.Match(rsData.Fields(iFieldShift).Value, arrShift, _
_
0)
tmpDate = rsData.Fields(iFieldDate)
For i = 0 To iFieldCount - 1
arrTmp(i) = rsData.Fields(arrFields(i)).Value
Next i
i = 0
objDict(varKey & "|" & rsData.Fields(iFieldDate)) = arrTmp
.MoveNext
Loop
.Close
End With
varDict = objDict.items
With wsTarget
For iDict = 0 To objDict.Count - 1
tmpShift = Split(objDict.Keys()(iDict), "|")(0)
tmpDate = Split(objDict.Keys()(iDict), "|")(1)
Set cTDate = wsTarget.Columns(1).Find(What:=tmpDate, LookAt:=xlWhole, LookIn:=xlValues,  _
_
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If cTDate Is Nothing Then
iDateCount = iDateCount + 1
With wsTarget
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = tmpDate
Set cTDate = .Columns(1).Find(What:=tmpDate, LookAt:=xlWhole, LookIn:=xlValues,  _
_
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
End If
iTRow = cTDate.Row
iTColTime = .Names("Zeiten_S" & tmpShift).RefersToRange.Column 'Zeiten_S1/Zeiten_S2/  _
_
Zeiten_S3 sind per Namensmanager definierte Spalten in Excel (Zeiten_S1 = AQ, etc.)
        'iTColTimeZAK = .Names("Zeiten_Z" & tmpShift).RefersToRange.Column 'ERGÄNZT  _
Siehe oben
iTColQty = .Names("Mengen_S" & tmpShift).RefersToRange.Column
iTColEmp = .Names("MA_S" & tmpShift).RefersToRange.Column
.Cells(iTRow, iTColTime).FormulaLocal = "=" & varDict(iDict)(5)
'.Cells(iTRow, iTColTimeZAK).FormulaLocal = "=" & varDict(iDict)(5) 'ERGÄNZT
.Range(.Cells(iTRow, iTColQty), .Cells(iTRow, iTColQty).Offset(0, iProcess +  _
iProcess_T8 - 1)) = varDict(iDict)
iOffset = iTColTime - (iTColEmp + iProcess + iProcess_T8)
'iOffsetZAK = iTColTimeZAK - (iTColEmp + iProcess + iProcess_T8) 'ERGÄNZT
'.Cells(iTRow, iTColQty + 3 * (iProcess + iProcess_T8)).Formula
.Cells(iTRow, iTColEmp + iProcess + iProcess_T8).Formula = "=IF(RC1=0,"""",SUM(RC" &  _
iTColEmp & ":RC[-1]))"
.Range(.Cells(iTRow, iTColTime - 1), .Cells(iTRow, iTColTime - 1).Offset(0, -(iProcess + _
_
iProcess_T8 - 1))).Formula = "=IF(RC" & iTColEmp + iProcess + iProcess_T8 & "=0,"""",RC[-" &  _
iOffset & "]/RC" & iTColEmp + iProcess + iProcess_T8 & "*RC" & iTColTime & ")"
'.Range(.Cells(iTRow, iTColTimeZAK - 1), .Cells(iTRow, iTColTimeZAK - 1).Offset(0, -( _
iProcess + iProcess_T8 - 1))).Formula = "=IF(RC" & iTColEmp + iProcess + iProcess_T8 & "=0,"""", _
RC[-" & iOffsetZAK & "]/RC" & iTColEmp + iProcess + iProcess_T8 & "*RC" & iTColTimeZAK & ")" 'ERGÄNZT
NextRecordSet:
Next iDict
End With
ThisWorkbook.Activate
Application.ScreenUpdating = True
MsgBox "Daten erfolgreich übertragen!" & Chr(10) & _
"Auswertung: " & sQuery & Chr(10) & _
"Gefundene Datensätze: " & dbRecCount & Chr(10) & _
"Datensätze aufgrund felender Zielzelle übersprungen: " & iDateCount, vbInformation +   _
_
vbOKOnly, "Datentransfer erfolgreich"
EndQuery:
dbHattdorf.Close
objAcc.Application.Quit
Set qryTarget = Nothing
Set dbHattdorf = Nothing
Set rsData = Nothing
Set objAcc = Nothing
If VBA.UserForms.Count > 0 Then
For iUF = 0 To VBA.UserForms.Count - 1
Unload VBA.UserForms(iUF)
Next iUF
End If
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
Select Case Err.Number
Case 7866, 3024
If MsgBox("Die Access-Datenbank, auf die diese Datei referenziert wurde verschoben oder  _
_
wird derzeit verwendet. Möchten Sie einen anderen Speicherort auswählen?", vbQuestion + vbYesNo, _
"Datenbank konnte nicht geöffnet werden") = vbYes Then
Err.Clear
sDBName = Application.GetOpenFilename("Microsoft Access Datenbanken (*.mdb; *.accdb) _
_
, *.mdb; *.accdb", , "Microsoft Access Datenbank öffnen", , False)
If sDBName  "Falsch" Then
GoTo OpenNewDB
End If
Else
Err.Clear
End If
Case 3021
Err.Clear
MsgBox "Keine Larc-Daten im Zeitraum " & dFromDate & "-" & dToDate & " vorhanden. Die   _
_
Abfrage wird beendet", vbInformation + vbOKOnly, "Datentransfer fehlgeschlagen"
Case Else
MsgBox Err.Number & ": " & Err.Description & Chr(10) & "Bitte wenden Sie sich an den  _
Administrator.", vbInformation
Err.Clear
Resume
End Select
If Not objAcc.CurrentDb Is Nothing Then
dbHattdorf.Close
End If
objAcc.Application.Quit
Set qryTarget = Nothing
Set dbHattdorf = Nothing
Set rsData = Nothing
Set objAcc = Nothing
If VBA.UserForms.Count > 0 Then
For iUF = 0 To VBA.UserForms.Count - 1
Unload VBA.UserForms(iUF)
Next iUF
End If
Application.ScreenUpdating = True
End Sub