Option Compare Database
Option Explicit
Public Const sTrail As String = " - Amt in (US$)" 'Trail string for field names yearly amounts
Public Sub MainCaller()
Const sLinkFieldOne As String = "ApplicationID" 'Fldname of PK of sTblNameForeCast
Const sTblNameForeCast As String = "ttblApplicationsForEMCApproval" 'Name of the created temptable
Const sLinkFieldTwo As String = "ApplicationID" 'Fldname of FK in sQueryToLinkName
Const sQueryToLinkName As String = "qryApplication" 'The query with all fields to display except the yearly amounts, and having the ApplicationID field in the select statement
Const sTempQueryName As String = "qryApplicationsForEMCApproval" 'The name of the query to built
Dim blnSumAmounts As Boolean 'Switch to tell routine if the results need to be grouped and thus needing to sum and group fields.
Dim sSumThisFlds As String 'If you want a summarized result, then specifify the fields that need to be summed, except for the yearly dynamic fields
'All fields that are not summed, will automatically be the group fields
blnSumAmounts = True 'Switch to false if you don't want summarized results
sSumThisFlds = "AmountApproved"
BuiltTableWithQuery sQueryToLinkName, sTblNameForeCast, sLinkFieldOne, sLinkFieldTwo, sTempQueryName, blnSumAmounts, sSumThisFlds
End Sub
Public Sub BuiltTableWithQuery(ByVal sQueryToLinkName As String, _
ByVal sTblNameForeCast As String, _
ByVal sLinkFieldOne As String, _
ByVal sLinkFieldTwo As String, _
ByVal sTempQueryName As String, _
ByVal blnSumAmounts As Boolean, _
Optional ByVal sSumThisFlds As String = "")
'Routine that creates all entities
'1 create the forecast table
'2 create array with fieldnames
'3 create the querydef
Dim sAmtYFlds As String 'String to hold the dynamic fieldnames for comparison
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim qdf As DAO.QueryDef
Dim rs As DAO.Recordset
Dim iFldCnt As Integer
Dim sFields() As String
Dim sSumFields() As String
Dim sSQL As String
Dim s As String
Dim sSelFlds As String
Dim sGroupFlds As String
Dim sFlds As String
'Create the forecast table
CreateTempTable sTblNameForeCast
Set dbs = CurrentDb
'Get the fieldnames from the QueryToLink, ignore the link fields
Set qdf = dbs.QueryDefs(sQueryToLinkName)
iFldCnt = 0
For Each fld In qdf.Fields
'Test if fld = sum field
If blnSumAmounts And InStr(1, sSumThisFlds, fld.Name, vbTextCompare)<> 0 Then 'It's a sum field
ReDim Preserve sFields(iFldCnt)
sFields(iFldCnt) = "Sum([" & fld.Name & "]) as [Total " & fld.Name & "]"
iFldCnt = iFldCnt + 1
ElseIf fld.Name = sLinkFieldOne Or fld.Name = sLinkFieldTwo Then
'Ignore field
Else
ReDim Preserve sFields(iFldCnt)
sFields(iFldCnt) = "[" & fld.Name & "]"
If blnSumAmounts Then sGroupFlds = sGroupFlds & ", " & "[" & fld.Name & "]"
iFldCnt = iFldCnt + 1
End If
Next fld
Set tdf = dbs.TableDefs(sTblNameForeCast)
'load all amtFlds from function
sAmtYFlds = sAmountYearFields
'test if current fieldname is in the sAmtYFlds string
'extract year amount fieldnames from tempforecast into array
'This is to eliminate all fields other than the dynamic fields
For Each fld In tdf.Fields
If InStr(1, sAmtYFlds, fld.Name, vbTextCompare) > 0 Then
ReDim Preserve sFields(iFldCnt)
If blnSumAmounts Then
sFields(iFldCnt) = "Sum([" & fld.Name & "]) as [Total " & fld.Name & "]"
iFldCnt = iFldCnt + 1
Else
sFields(iFldCnt) = "[" & fld.Name & "]"
iFldCnt = iFldCnt + 1
End If
End If
Next fld
sSelFlds = Join(sFields, ", ")
sSQL = SQL_JoinTwoTbls(sQueryToLinkName, sTblNameForeCast, sLinkFieldOne, sLinkFieldTwo, sSelFlds, Mid(sGroupFlds, 3))
'test if the query already exists, if so delete
For Each qdf In dbs.QueryDefs
If qdf.Name = sTempQueryName Then dbs.QueryDefs.Delete qdf.Name
Next qdf
Set qdf = dbs.CreateQueryDef(sTempQueryName, sSQL)
End Sub
Public Function sAmountYearFields() As String
'creates a string with all possible values for dynamic field name regarding amounts using the const sTrail
'result = 2000/../2100 - Amt in (US$)
Dim sY(100) As String '100 years forward, if you still use this system by then, maybe it's time to update
Dim sFlds As String 'string for result
Dim yCnt As Long 'counter for years
Const iFY As Long = 2000 'starting year
For yCnt = 0 To UBound(sY)
sY(yCnt) = iFY + yCnt & sTrail
Next yCnt
sAmountYearFields = Join(sY, ", ")
End Function
Public Function SQL_JoinTwoTbls(ByVal sTblOne As String, _
ByVal sTblTwo As String, _
ByVal sJoinFldOne As String, _
ByVal sJoinFldTwo As String, _
ByVal sSelFlds As String, _
Optional ByVal sGroupFlds As String)
'String function which creates a join between two tables
'Within this context, a table can also be a queryDef
Dim sSQL As String
If Len(sGroupFlds)<> 0 Then
sGroupFlds = "Group By " & sGroupFlds
End If
sSQL = "Select " & sSelFlds & " " _
& "FROM " & sTblOne & " INNER JOIN " & sTblTwo & " ON " & sTblOne & "." & sJoinFldOne & " = " & sTblTwo & "." & sJoinFldTwo & " " _
& sGroupFlds
SQL_JoinTwoTbls = sSQL
End Function
