Dim xlApp As New Excel.Application
Dim xlWB As Object
Dim Lists(2) As Variant
Dim Tables(2) As Variant
Dim FitID As String
Dim i As Long
Dim l As Long
Dim c As Control
Dim SDict As Dictionary
Dim FDict As Dictionary
Dim WDict As Dictionary
Dim rs As Recordset
Dim SELECTItem As String
Dim SELECTString As String
Dim FROMString As String
Dim WHEREString As String
Dim vkey As Variant
Dim joinCount As Long
Dim toggle As Boolean
Dim DoesNotMatch As String
Dim sql As String: sql = ""
'Dim ReportCheck As Boolean
'Dim StatusFITID As String
'On Error GoTo ErrorCatch
If MsgBox("Are you sure you want to run the report?", vbYesNo) = vbNo Then Exit Sub
DoCmd.Hourglass True
'This finds out which column List has been ticked
Select Case True
Case Me.CFRCheck
Lists(0) = "CFRMissMatchList"
Tables(0) = "CFR"
FitID = "[CFR].[Extension reference] AS FullFITID"
'StatusFITID = "[CFR].[Extension reference]"
' sql = sql & " SELECT DISTINCT"
' sql = sql & " [FIT ID]"
' sql = sql & " FROM"
' sql = sql & " CFR "
Case Me.DatabaseCheck
Lists(0) = "DatabaseMissMatchList"
Tables(0) = "Database"
FitID = "[Database].FullFITID"
'StatusFITID = "[Database].FullFITID"
Case Me.CSCheck
Lists(0) = "CSMissMatchList"
Tables(0) = "CS"
FitID = "[CS].[FIT ID] AS FullFITID"
'StatusFITID = "[CS].[FIT ID]"
Case Else
GoTo UserError
End Select
'This then loops then controls on the form to find the other missmatch listboxes and checks that the listcount is the same as the ticked list.
i = 1
For Each c In Controls
If c.Tag = "LoopMe" Then
If c.Name <> Lists(0) Then
If Not IsNull(Me.Controls(c.Name).ItemData(0)) Then
Lists(i) = c.Name
Tables(i) = Left(c.Name, InStr(1, c.Name, "Miss") - 1)
If Me.Controls(c.Name).ListCount <> Me.Controls(Lists(0)).ListCount Then GoTo UserError
End If
i = i + 1
If i = 3 Then Exit For
End If
End If
Next
'If data only in one list stop.
If Lists(1) = "" And Lists(2) = "" Then GoTo UserError
'Loop the main list looping through tables creating SELECT String then move to excel
For i = 0 To Me.Controls(Lists(0)).ListCount - 1
Set SDict = New Dictionary
Set FDict = New Dictionary
Set WDict = New Dictionary
For l = 0 To UBound(Lists)
If Lists(l) <> "" Then
'Check if the selected column shows in the custom validation table. If so add the validation
Set rs = CurrentDb.OpenRecordset("SELECT * FROM CustomValidation WHERE Report = '" & Tables(l) & "' AND ColumnName = '" & Me.Controls(Lists(l)).ItemData(i) & "'")
If Not rs.EOF Then
SELECTItem = Replace(rs("Rule"), "var", "[" & Tables(l) & "].[" & rs("ColumnName") & "]") & ""
SELECTItem = Replace(SELECTItem, "|", "")
Else
SELECTItem = "[" & Tables(l) & "].[" & Me.Controls(Lists(l)).ItemData(i) & "]"
End If
'Create Dictionaries of needed items for the SQL
If Not SDict.Exists(SELECTItem) Then
SDict.Add SELECTItem, SELECTItem & " AS " & Tables(l) & "Data"
End If
If Not WDict.Exists(SELECTItem) Then
WDict.Add SELECTItem, SELECTItem
End If
If Not FDict.Exists(SELECTItem) And l <> 0 Then
Select Case Tables(l)
Case Is = "CFR"
FROMString = "LEFT JOIN [CFR] ON " & JoinItem(CStr(Tables(0))) & " = " & JoinItem("CFR") & " "
Case Is = "CS"
FROMString = "LEFT JOIN [CS] ON " & JoinItem(CStr(Tables(0))) & " = " & JoinItem("CS") & " "
Case Is = "Database"
FROMString = "LEFT JOIN " & DBData(Me.Controls(Lists(l)).ItemData(i)) & " ON " & JoinItem(CStr(Tables(0))) & " = " & JoinItem("Database") & " "
End Select
If Not FDict.Exists(FROMString) Then
FDict.Add FROMString, FROMString
End If
End If
End If
Next l
'Create the SQL string
SELECTString = "SELECT DISTINCT " & FitID
For Each vkey In SDict.Keys
SELECTString = SELECTString & ", " & SDict(vkey)
Next
'REMOVED as takes way too long!
'Simon add if here to add Database satus based onFirst FitId
' If Me.StatusCheck = True Then
' 'SELECTString = SELECTString & ", AddStatus(" & StatusFITID & ") AS DatabaseStatus"
'
' SELECTString = SELECTString & ", (SELECT TOP 1 status.description " _
' & "FROM (statusCodes " _
' & "INNER JOIN installation ON statusCodes.installationID = installation.installationID) " _
' & "INNER JOIN status ON (statusCodes.StatusID = status.StatusID AND status.statusGroup = 'registration') " _
' & "WHERE 'FIT' & installation.FITID & '-' & installation.ExtensionReference = " & StatusFITID & " AND statusCodes.StatusGroup = 'registration' " _
' & "ORDER BY RecordID DESC, dateOfChange DESC) AS DatabaseStatus"
'
'
' End If
Debug.Print SELECTString
If Tables(0) = "Database" Then
FROMString = "FROM (" & DBData(Me.Controls(Lists(0)).ItemData(i))
Else
FROMString = "FROM ([" & Tables(0) & "]"
End If
joinCount = 0
For Each vkey In FDict.Keys
joinCount = joinCount + 1
FROMString = FROMString & " " & FDict(vkey) & ")"
Next
If joinCount = 2 Then FROMString = Left(FROMString, Len(FROMString) - 1)
Debug.Print FROMString
WHEREString = "WHERE "
toggle = False
For Each vkey In WDict.Keys
If toggle = False Then
DoesNotMatch = WDict(vkey) & " <> "
toggle = True
Else
WHEREString = WHEREString & DoesNotMatch & WDict(vkey) & " OR "
End If
Next
WHEREString = Left(WHEREString, Len(WHEREString) - 4)
Debug.Print WHEREString
If ReportCheck = True Then
sql = sql & " SELECT"
sql = sql & " [FullFITID] AS FITS"
sql = sql & " FROM"
sql = sql & " [" & Tables(0) & "]"
sql = sql & " LEFT JOIN"
sql = sql & " (" & SELECTString & " " & FROMString & " " & WHEREString & ")"
' sql = sql & " ON"
' sql = sql & " [" & Tables(0) & "].[FullFITID]=[CS].[FullFITID]"
' sql = sql & " LEFT JOIN"
' sql = sql & " (" & SELECTString & " " & FROMString & " " & WHEREString & ")"
' sql = sql & " ON"
' sql = sql & " [" & Tables(0) & "].[FullFITID]=[" & Tables(2) & "].[FullFITID]"
End If
Debug.Print sql
'Export the query to Excel
'ExportQuery SELECTString & " " & FROMString & " " & WHEREString, True, Me.Controls(Lists(0)).ItemData(i), i, xlApp, xlWB
ExportQuery SELECTString & " " & FROMString & " " & WHEREString, True, Me.Controls(Lists(0)).ItemData(i), i, xlApp, xlWB
Next i
MsgBox "All reports have been exported."
DoCmd.Hourglass False
Exit Sub
ErrorCatch:
If MsgBox("Error running - " & Me.Controls(Lists(0)).ItemData(i) & "." & vbCrLf & vbCrLf & Err.Description & vbCrLf & vbCrLf & "Carry on running reconcilation reports?", vbYesNo) = vbYes Then
Resume Next
End If
DoCmd.Hourglass False
Exit Sub
UserError:
MsgBox "Please make sure you have data in at least 2 'Miss-Match' columns and that all list with data have the same amount of items selected."
DoCmd.Hourglass False
