Home Code

VBA > Data > Make Cross-Reference Records

Make cross-reference records by separating values from a field with multiple values.

Table1 has values that need to be parsed and stored in Table2. Cross-reference records need to be created in TableX.

video tutorial

YouTube

video: Make Records in an Access Cross-Reference Table with VBA (9:00)
(and a little about HTML)

Code

'  module: mod_MakeXRefRecords
'*************** Code Start *****************************************************
' Purpose  : make cross-reference records
' Author   : crystal (strive4peace)
' License  : below code
' Code List: www.MsAccessGurus.com/code.htm
'          : http://msaccessgurus.com/VBA/Code/Data_CrossRef.htm
'
'-------------------------------------------------------------------------------
'                              launch_MakeXRefRecords
'-------------------------------------------------------------------------------
Sub launch_MakeXRefRecords() 
'200920 strive4peace, 21
   '
   'CLICK HERE
   'Press F5 to Run!
   '
   Dim sTable1 As String _ 
      ,sTable2 As String _ 
      ,sTableX As String _ 
      ,sTextField1 As String _ 
      ,sTextField2 As String _ 
      ,sPk1 As String _ 
      ,sPk2 As String 
   '--------------------------- customize 
   sTable1 =  "Table with data to separate"
   sTable2 =  "Table to create records in"
   sTableX =  "Cross-Reference table"
   sTextField1 =  "field to separate"
   sTextField2 =  "field for single values"
   sPk1 =  "primary key fieldname of Table1"
   sPk2 =  "primary key fieldname of Table2"
   '--------------------------- 
      
   Call MakeXRefRecords( _ 
      sTable1,sTable2,sTableX _ 
      ,sTextField1,sTextField2 _ 
      ,sPk1,sPk2 _ 
      ) 
End Sub 

'-------------------------------------------------------------------------------
'                              MakeXRefRecords
'-------------------------------------------------------------------------------
Sub MakeXRefRecords( _ 
   psTable1 As String _ 
   ,psTable2 As String _ 
   ,psTableX As String _ 
   ,psTextField1 As String _ 
   ,psTextField2 As String _ 
   ,psPk1 As String _ 
   ,psPk2 As String _ 
   ,Optional psDeli As String =  "," _ 
   ) 
'200920 strive4peace, 21
' separate a list of values in Table1.TextField1
' add records for Table2.TextField2 as needed
' Create cross-reference record in TableX with Pk1 and Pk2
' Assume PK/FK fieldnames are the same.

   'CALLs
   '  RunTheSQL
   
   On Error GoTo Proc_Err 

   'dimension scalar variables
   Dim sValue As String _ 
      ,sWhere As String _ 
      ,sSQL As String _ 
      ,sMsg As String _ 
      ,i As Integer _ 
      ,nPk1 As Long _ 
      ,nPk2 As Long _ 
      ,nCount1 As Long _ 
      ,nCount2 As Long _ 
      ,nCountX As Long 

   Dim asItems() As String 
      
   'dimension object variables
   Dim db As DAO.Database _ 
      ,rs1 As DAO.Recordset _ 
      ,rs2 As DAO.Recordset 
      
   'set db and open recordsets
   Set db = CurrentDb 
   Set rs1 = db.OpenRecordset(psTable1,dbOpenDynaset) 
   Set rs2 = db.OpenRecordset(psTable2,dbOpenDynaset) 
   
   'initialize counters
   nCount1 = 0  'records separated in table1
   nCount2 = 0  'records added to table2
   nCountX = 0  'records added to x-ref table
 
   With rs2 
      Do While Not rs1.EOF 
         nPk1 = -99 
         sValue = Trim(Nz(rs1.Fields(psTextField1), "")) 
         
         If sValue <>  "" Then 
            nCount1 = nCount1 + 1 
            'get primary key from table1
            nPk1 = rs1.Fields(psPk1) 
            asItems = Split(sValue,psDeli) 
            
            'loop through items
            For i = LBound(asItems) To UBound(asItems) 
               nPk2 = -99 
               sValue = Trim(asItems(i)) 
               
               If sValue <>  "" Then 
                  'see if value is already in table2
                  sWhere =  "[" & psTextField2 &  "] = """ _ 
                     & sValue &  """"
                  .FindFirst sWhere 
                  If .NoMatch Then 
                     nCount2 = nCount2 + 1 
                     'add record
                     .AddNew 
                     .Fields(psTextField2) = sValue 
                     .Update 
                     .Bookmark = .LastModified 
                  End If 
                  nPk2 = .Fields(psPk2) 
                  
                  'add x-reference record
                  sSQL =  "INSERT INTO [" & psTableX &  "] (" _ 
                     &  "[" & psPk1 &  "], [" & psPk2 &  "])" _ 
                     &  " SELECT " & nPk1 &  ", " & nPk2 
                  'call RunTheSQL
                  If RunTheSQL(db,sSQL) > 0 Then 
                     nCountX = nCountX + 1 
                  Else 
                     sMsg =  "Error executing SQL statement" _ 
                        & vbCrLf & vbCrLf &  "OK to continue " _ 
                        & vbCrLf &  "Cancel to stop "
                     If MsgBox(sMsg,vbOKCancel, "Error") = vbCancel Then 
                           GoTo Proc_Exit 
                     End If 
                  End If 
               End If  'psTextField2 has value
            Next i  'asItems
         End If  'psTextField1 has value
         rs1.MoveNext 
      Loop  'rs1
   End With  'rs2
   
   db.TableDefs.Refresh 
   
   sMsg = nCount1 &  " records separated from " & psTable1 _ 
      & vbCrLf & nCount2 &  " records created in " & psTable2 _ 
      & vbCrLf & nCountX &  " records created in " & psTableX _ 
   
   MsgBox sMsg,, "Done"
   
Proc_Exit: 
   On Error Resume Next 
   If Not rs2 Is Nothing Then 
      rs2.Close 
      Set rs2 = Nothing 
   End If 
   If Not rs1 Is Nothing Then 
      rs1.Close 
      Set rs1 = Nothing 
   End If 
   Set db = Nothing 
   Exit Sub 
  
Proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   MakeXRefRecords"
   Resume Proc_Exit 
   Resume 
   
End Sub 

Keyword and comments in code were colored with this free Color Code add-in

Goto Top  

Goto Top