Function VeldenSamenvoegen(Tabel As String, Velden As String, Optional Delim As String) As Boolean
Dim qd As DAO.QueryDef
Dim rs1 As DAO.Recordset, rs2 As DAO.Recordset
Dim strSQL As String, sB1 As String, sB2 As String, sDelim As String
Dim sV As Variant, arrResult() As Variant
Dim varResult As String
Dim bAdd As Boolean, iAdd As Integer, i As Integer
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
On Error Resume Next
'-------------------------------------------------------------------------------------------------------
'Veldnamen uitsplitsen in een matrix om de tabel aan te kunnen maken.
'Delimiter komt ofwel uit de procedure, ofwel is een vast teken.
'-------------------------------------------------------------------------------------------------------
If Delim = vbNullString Then sdelimn = "|" Else: sDelim = Delim
If InStr(1, Velden, sDelim) = 0 Then
MsgBox "Er is maar één veld ingevuld; hiermee kan niet worden samengevoegd.", vbOKOnly + vbCritical
Exit Function
Else
sV = Split(Velden, sDelim)
ReDim arrResult(UBound(sV))
End If
'-------------------------------------------------------------------------------------------------------
'Tijdelijke tabel aanmaken met de gevraagde velden
'-------------------------------------------------------------------------------------------------------
CurrentDb.TableDefs.Delete "tmpSamenvoegen"
On Error GoTo Hell
Set tdf = CurrentDb.CreateTableDef("tmpSamenvoegen")
With tdf
'---------------------------------------------------------------------------------------------------
'AutoNummer: Long met Unieke ID
'---------------------------------------------------------------------------------------------------
Set fld = .CreateField("KeyID", dbLong)
fld.Attributes = dbAutoIncrField + dbFixedField
.Fields.Append fld
For i = LBound(sV) To UBound(sV)
'-----------------------------------------------------------------------------------------------
'Tekstveld: maximum 100 karakters; verplicht veld. Dit is het groepeerveld.
'-----------------------------------------------------------------------------------------------
If i = LBound(sV) Then
Set fld = .CreateField(sV(i), dbText, 100)
fld.Required = True
.Fields.Append fld
Else
'-------------------------------------------------------------------------------------------
'Memoveld voor overige velden. Gebruik dit als er teveel records zijn.
'-------------------------------------------------------------------------------------------
.Fields.Append .CreateField(sV(i), dbMemo)
'-------------------------------------------------------------------------------------------
'tekstveld voor overige velden. Gebruik dit als er weinig records zijn
'-------------------------------------------------------------------------------------------
'.Fields.Append .CreateField(sV(i), dbText, 255)
End If
Next i
'---------------------------------------------------------------------------------------------------
'Ja/Nee veldje. Altijd handig bij mailings.
'---------------------------------------------------------------------------------------------------
.Fields.Append .CreateField("Gemaild", dbBoolean)
'---------------------------------------------------------------------------------------------------
'Valuta veld. Je zal maar geld willen hebben.
'---------------------------------------------------------------------------------------------------
.Fields.Append .CreateField("Bedrag", dbCurrency)
End With
CurrentDb.TableDefs.Append tdf
'-------------------------------------------------------------------------------------------------------
'Query string opbouwen om de gegevens uit te lezen.
'Hierbij is het éérste veld altijd het groepeerveld.
'-------------------------------------------------------------------------------------------------------
strSQL = "SELECT "
For i = LBound(sV) To UBound(sV)
strSQL = strSQL & sV(i)
If Not i = UBound(sV) Then strSQL = strSQL & ", "
Next i
strSQL = strSQL & " FROM " & Tabel & " ORDER BY " & sV(LBound(sV)) & ", " & sV(LBound(sV) + 1)
'-------------------------------------------------------------------------------------------------------
'Recordsets openen; tijdelijke tabel en query
'-------------------------------------------------------------------------------------------------------
Set rs1 = CurrentDb.OpenRecordset(strSQL)
Set rs2 = CurrentDb.OpenRecordset("tmpSamenvoegen")
With rs1
.MoveLast
.MoveFirst
'---------------------------------------------------------------------------------------------------
'Door query lopen en de eerste waarden toewijzen aan de matrix variabele
'---------------------------------------------------------------------------------------------------
sB1 = .Fields(0).Value
arrResult(LBound(arrResult)) = .Fields(0).Value
sB2 = sB1
Do While Not .EOF
'-----------------------------------------------------------------------------------------------
'Door de overige records lopen en de waarden toewijzen aan de matrix variabele
'-----------------------------------------------------------------------------------------------
Do Until sB1 <> sB2
For i = LBound(sV) + 1 To UBound(sV)
If Not Nz(.Fields(i), "") = "" Then
If Not arrResult(i) = vbNullString Then arrResult(i) = arrResult(i) & "; "
arrResult(i) = arrResult(i) & .Fields(i).Value
End If
Next i
.MoveNext
If Not .EOF Then
sB2 = .Fields(0).Value
Else
sB2 = ""
Exit Do
End If
Loop
'-----------------------------------------------------------------------------------------------
'De ingelezen waarden in de tijdelijke tabel wegschrijven
'-----------------------------------------------------------------------------------------------
rs2.AddNew
For i = LBound(arrResult) To UBound(arrResult)
rs2.Fields(i + 1).Value = arrResult(i)
arrResult(i) = Null
Next i
rs2.Update
If Not .EOF Then
sB1 = .Fields(0).Value
Else
sB1 = ""
Exit Do
End If
arrResult(LBound(arrResult)) = .Fields(0).Value
Loop
'---------------------------------------------------------------------------------------------------
'Recordsets sluiten
'---------------------------------------------------------------------------------------------------
rs1.Close
rs2.Close
End With
VeldenSamenvoegen = True
Exit Function
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Hell:
VeldenSamenvoegen = False
End Function
.
