Here it is.
Create a new module if you don't already have one.
Type in Option Explicit.
Paste this code in.
I am reading from 'Table5' and writing to 'Table5_Write'.
In Table5_Write - PatientID must not be a Primary Key.
Make sure your Table names match what you have in your Database.
[table1 & table3?]
Highlight the first row -
Function Function Split_Field_Values()
Hit the run button or press F5.
You should have what you need.
Please test to make sure it is performing to expectation.
I hope this gives you a starting point to using VBA.
Code:
Function Split_Field_Values()
'This function splits each row with multiple ";" - delimited values in one field
'. . . into multiple rows with one of the values in each row
'. . . and writes the rows to a 'receiving' Table [Table5_Write].
'Table5 contains rows which have Multiple values in the TestID field
'Each row has a PK PatientID field.
'Table5_Write has a PatiendID [cannot be Primary Key] and a TestID field.
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strField1, strField2, strNewField1, strNewField2, strSQL As String
Dim intPos, intPos2, intCount, intLength As Integer
Dim Found As Boolean
On Error GoTo Error_Handle
DoCmd.SetWarnings False
Set db = CurrentDb
strSQL = "Select * From [Table5] ORDER BY [PatientID]"
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
With rs
'This loop goes through all the records in strSQL - one by one.
Do While Not rs.EOF
'Set intPos = 1 because we are now at a new row in the recordset.
intPos = 1
intCount = 1
'Get the values from the current row.
strField1 = rs![PatientID]
strField2 = rs![TestID]
'Get the first value.
If InStr(intPos, strField2, ";") > 0 Then ' ";" found.
Found = True
strNewField2 = Left(strField2, (InStr(intPos, strField2, ";") - 1))
strSQL = "INSERT INTO Table5_Write (PatientID, TestID) "
strSQL = strSQL & "VALUES (" & strField1 & "," & "'" & strNewField2 & "'" & "); "
'Execute Insert SQL.
DoCmd.RunSQL strSQL
Else ' ";" not found.
Found = False
If Len(strField2) > 0 Then ' the field is not empty.
strNewField2 = strField2
strSQL = "INSERT INTO Table5_Write (PatientID, TestID) "
strSQL = strSQL & "VALUES (" & strField1 & "," & "'" & strNewField2 & "'" & "); "
'Execute Insert SQL.
DoCmd.RunSQL strSQL
Else ' the field is empty.
'Not sure if you'll ever have a PatientID with no TestIDs in it . . .
'Just leaving a place holder here in case you need to code.
End If
End If
'Get new start position [intPos].
intPos = InStr(intPos, strField2, ";") + 1
If Not (Found) Then 'There is no ";" in this row - single value already written.
'Do nothing
Else 'A ";" was found - keep going.
'This Do While Loop keeps searching strField2 of the current row of data till there are no more instances of ";"
Do While intPos > 0
intPos2 = 0
intPos2 = InStr(intPos + 1, strField2, ";")
intLength = (intPos2 - intPos)
If intLength > 0 Then
'Get subsequent values from the TestID string.
strNewField2 = Mid(strField2, intPos, intLength)
'Write row with last of the delimited values here.
'Create SQL for Last Row of data that is still stored even though Access found the EOF.
strSQL = "INSERT INTO Table5_Write (PatientID, TestID) "
strSQL = strSQL & "VALUES (" & strField1 & "," & "'" & strNewField2 & "'" & "); "
'Execute Insert SQL.
DoCmd.RunSQL strSQL
Else
'The Instr function returned a 0 - no more ";" found = last value in field.
'Write everything to the right of the last ";".
strNewField2 = Right(strField2, (Len(strField2) - (intPos - 1)))
'Write row with last of the delimited values here.
'Create SQL for Last Row of data that is still stored even though Access found the EOF.
strSQL = "INSERT INTO Table5_Write (PatientID, TestID) "
strSQL = strSQL & "VALUES (" & strField1 & "," & "'" & strNewField2 & "'" & "); "
'Execute Insert SQL.
DoCmd.RunSQL strSQL
'Since we are at the last value in field - Get out of this Loop
'without incrementing intPos.
'I know this is not the most elegant way out of this . . .
Exit Do
End If
'Set intPos to the last ";" encountered [intPos2].
intPos = intPos2 + 1
intCount = intCount + 1
Loop
End If
.MoveNext 'Move to next record in recordset.
Loop 'Back to 'Do While' to check if we are at the end of the recordset.
Exit_Split_Field_Values:
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Set db = Nothing
DoCmd.SetWarnings True
Exit Function
Error_Handle:
MsgBox Err & " " & Error$
Resume Exit_Split_Field_Values:
End With
End Function
Let me know how it goes.
Mark the thread 'Solved' if it resolves your issue.
Windows 7 32bit 
Access 2010 32bit
Reply With Quote
