Public Function DConcat(strDataSource As String, _
                        strConcatenateField As String, _
                        strDelimiter As String, _
                        ParamArray aFldVal() As Variant) _
       As String
    '*************************************************************************
    'DConcat()
    'Written by Azli Hassan, http://azlihassan.com/apps
    '© Azli Hassan, http://azlihassan.com/apps
    '
    'Updated (5/6/2018): Can now pass a single WHERE string to aFldVal
    '                    as you would with regular domain aggregate functions.
    'Updated (5/26/2018): Added option to specify string to use as delimiter
    '
    'PURPOSE:   To concatenate all the values of a field in a
    '           table or query that meets the grouping of the
    '           calling query
    '
    'ARGUMENTS:
    ' 1) strDataSource [String]
    '    - Name of table/query that field to be concatenated is in
    '    - May also be an SQL string to be used to set a recordset.
    ' 2) strConcatenateField [String]
    '    - Name of field to be concatenated.
    ' 2) strDelimiter [String]
    '    - String to use as delimiter (seperator) between value.
    ' 4) aFldVal() [Array]
    '    - An array of GroupBy fields and their values.
    '      Must be pass from the query in a repeating order of
    '      Field name (as a string), then the Field value, and so on
    '      By default, concatenated values are ordered ascendingly.
    '      If you need a particular sort order then you'll need to
    '      pass a single WHERE and ORDER BY SQL statement to aFldVal().
    '
    'RETURNS: Concatenated string of UNIQUE values of concatenated string
    '         where data sources fields match the calling queries groupings
    '
    'TIP: Remove or Comments out the Debug.Print statements
    '     AFTER you understand how the function works.
    '*************************************************************************

    On Error GoTo ErrMsg:

    Dim Db As DAO.Database, _
        rst As DAO.Recordset, _
        fldConcatenate As DAO.Field
    Dim strParamArray As String, _
        lngNumOfElements As Long, _
        blnIsNumeric As Boolean
    Dim strSql As String, _
        strSELECT As String, _
        strFROM As String, _
        strWhere As String, _
        strCRITERIA As String
    Dim blnText As Boolean
    Dim strAdd As String

    'Check that table/query exists in current database
    'IsTableQuery() - http://support.microsoft.com/kb/210398/
    If Not IsTableQuery("", strDataSource) Then
        Dim rstTemp As DAO.Recordset
        Set rstTemp = CurrentDb.OpenRecordset(strDataSource)
        If rstTemp.BOF And rstTemp.EOF Then GoTo ExitHere
        rstTemp.Close
        strFROM = "FROM (" & Left(strDataSource, Len(strDataSource) - 1) & _
                  ") as myDataSource "
    Else
        strFROM = "FROM " & strDataSource & " "
    End If

    Set Db = CurrentDb()
    Set rst = Db.OpenRecordset(strDataSource)

    'Check that table/query has data
    If rst.BOF And rst.EOF Then GoTo ExitHere

    'Check if parramarray is empty
    If IsEmpty(aFldVal) Then
        DConcat = "#ERR-EmptyParramarray"
    End If
    
    'Check if only 1 thing was passed to parramarray.
    'If so, then assume the whole WHERE string was passed.
    If LBound(aFldVal) = UBound(aFldVal) Then
        'Only 1 element was passed
        strWhere = "WHERE "
        strWhere = strWhere & CStr(aFldVal(LBound(aFldVal)))
        strWhere = strWhere & ";"
    Else
        'More than 1 thing passed
        'Get number of elements in parramarray
        If LBound(aFldVal) = 0 Then
            lngNumOfElements = UBound(aFldVal) + 1
        Else
            lngNumOfElements = UBound(aFldVal) + 1
        End If
        'Check that paramarray has even number of elements
        If lngNumOfElements Mod 2 <> 0 Then Exit Function
        Dim i As Long
        For i = LBound(aFldVal) To UBound(aFldVal) Step 2
            blnIsNumeric = IsNumeric(aFldVal(i + 1))
            Select Case blnIsNumeric
            Case True
                strParamArray = strParamArray & "'" & aFldVal(i) & _
                                "', " & aFldVal(i + 1) & ", "
            Case False
                If IsDate(aFldVal(i + 1)) Then
                strParamArray = strParamArray & "'" & aFldVal(i) & _
                                "', #" & aFldVal(i + 1) & "#, "
                Else
                strParamArray = strParamArray & "'" & aFldVal(i) & _
                                "', '" & aFldVal(i + 1) & "', "
                End If
            End Select
        Next i
        strParamArray = Left(strParamArray, _
                             Len(strParamArray) - Len(", "))
    
        Debug.Print "DConcat('" & strDataSource & _
                    "', '" & strConcatenateField & "', " & _
                    strParamArray & ")"
    
        For i = LBound(aFldVal) To (UBound(aFldVal)) Step 2
            blnText = (rst.Fields(aFldVal(i)).Type = dbChar) Or _
                      (rst.Fields(aFldVal(i)).Type = dbMemo) Or _
                      (rst.Fields(aFldVal(i)).Type = dbText)
            Select Case blnText
            Case True
                strCRITERIA = "[" & aFldVal(i) & "] = '" & _
                              aFldVal(i + 1) & "'"
            Case False
                If rst.Fields(aFldVal(i)).Type = dbDate Then
                    strCRITERIA = "[" & aFldVal(i) & "] = " & _
                                  "#" & aFldVal(i + 1) & "#"
                Else
                    strCRITERIA = "[" & aFldVal(i) & "] = " & _
                                  aFldVal(i + 1)
                End If
            End Select
            strWhere = strWhere & strCRITERIA & " AND "
        Next i
        strWhere = "WHERE (" & strWhere
        strWhere = Left(strWhere, Len(strWhere) - Len(" AND "))
        strWhere = strWhere & ");"
    End If
    
    
    'Create SQL String to select distinct records
    'that match the query's "GroupBy" values
    'e.g. SELECT DISTINCT Reference
    '     FROM tblData
    '     WHERE ((ProductID=2211) AND (Description="10�F 15V"));

    strSELECT = "SELECT DISTINCT " & strConcatenateField & " "
    
    strSql = strSELECT & strFROM & strWhere
    Debug.Print strSql

    Set rst = Db.OpenRecordset(strSql)

    'Check that SQL recordset has data
    If rst.BOF And rst.EOF Then GoTo ExitHere
    rst.MoveFirst

    'Set recordset field Object
    Set fldConcatenate = rst.Fields(strConcatenateField)

    'Loop through ALL the records
    'in the SELECT DISTICT recordset
    While Not rst.EOF
        With rst
            If DConcat = "" Then
                'First value
                If Not IsNull(fldConcatenate) Then
                    DConcat = fldConcatenate
                End If
            Else
                If Not IsNull(fldConcatenate) Then
                    strAdd = strDelimiter & fldConcatenate
                    If InStr(1, DConcat, _
                             strAdd, vbTextCompare) = 0 Then
                        'Only add if unique
                        DConcat = DConcat & strAdd
                    End If
                End If
            End If
        End With
        rst.MoveNext
    Wend

ExitHere:
    On Error Resume Next
    rstTemp.Close
    rst.Close
    Db.Close
    Exit Function

ErrMsg:
    DConcat = "#ERR" & Err.Number
    Debug.Print "Err.Number = " & Err.Number & _
                ", Err.Description = " & Err.Description
    Resume ExitHere

End Function


Function IsTableQuery(DbName As String, TName As String) As Integer

'********************************************************
' FUNCTION: IsTableQuery()
'
' PURPOSE: Determine if a table or query exists.
'
' ARGUMENTS:
'   DbName: The name of the database. If the database name
'           is "" the current database is used.
'    TName: The name of a table or query.
'
' RETURNS: True (it exists) or False (it does not exist).
'
'********************************************************

Dim Db As DAO.Database, Found As Integer, Test As String
Const NAME_NOT_IN_COLLECTION = 3265

' Assume the table or query does not exist.
Found = False

' Trap for any errors.
On Error Resume Next

' If the database name is empty...
If Trim$(DbName) = "" Then
    ' ...then set Db to the current Db.
    Set Db = CurrentDb()
Else
    ' Otherwise, set Db to the specified open database.
    Set Db = DBEngine.Workspaces(0).OpenDatabase(DbName)

    ' See if an error occurred.
    If Err Then
        MsgBox "Could not find database to open: " & DbName
        IsTableQuery = False
        Exit Function
    End If
End If

' See if the name is in the Tables collection.
Test = Db.TableDefs(TName).Name
If Err <> NAME_NOT_IN_COLLECTION Then Found = True

' Reset the error variable.
Err = 0

' See if the name is in the Queries collection.
Test = Db.QueryDefs(TName$).Name
If Err <> NAME_NOT_IN_COLLECTION Then Found = True

Db.Close

IsTableQuery = Found

End Function