Access VBA

Generate Table from Another

This little ditty generates the whole thing into an Excel file that can be used as a Mail-Merge in Word in 3 seconds or less.

See Using Register table to get understanding of my stored values in Register table.

Private Sub cmdFramLabel_Click()
    'Using tblExhibits create file to mail merge frame labels
    ' Created 12/30/2024
    Dim RS          As Recordset
    Dim TR          As Recordset
    Dim tmpTable    As String
    Dim DB          As Database
    Dim ExhName     As String
    Dim X           As Long
    Dim R           As Long
    Dim SQLstr      As String
    Dim QUO         As String
    QUO = Chr(34)
    Set DB = CurrentDb()
     
    DoCmd.SetWarnings False  'Turn off warning before emptying table
    DoCmd.RunSQL "DELETE * FROM tmpFrameLabels"
    DoCmd.SetWarnings True
    Set TR = DB.OpenRecordset("tmpFrameLabels", dbOpenDynaset, dbSeeChanges)
    
    SQLstr = "SELECT tblExhibits.FirstFrame, tblExhibits.LastFrame, _
tblExhibits.NumberFrames, tblExhibits.Title, tblExhibits.Class, _
tblExhibits.Division, tblExhibits.ExhingYr" & vbCrLf
    SQLstr = SQLstr & " FROM tblExhibits" & vbCrLf
    SQLstr = SQLstr & " WHERE (((tblExhibits.ExhingYr) = KeyVal(" & QUO _
& "ShowYear" & QUO & ")))" & vbCrLf
    SQLstr = SQLstr & " ORDER BY tblExhibits.FirstFrame;"
    Debug.Print SQLstr
    R = 1	' Used on labels for frame numbers
    Set RS = DB.OpenRecordset(SQLstr, dbOpenDynaset, dbSeeChanges)
        RS.MoveFirst
        
            Do While Not RS.EOF
                If RS!NumberFrames = 1 Then
                With TR
                     .AddNew
                   !absfrmnumb = R
                   !NumbFrames = RS!NumberFrames
                   !firstfr = RS!FirstFrame
                   !lastfr = RS!LastFrame
                   !extitle = RS!Title
                   !exClass = RS!Class
                   !labelphrase = "Frame 1 of 1"
                   !rptCreation = Format(Now(), "mm/dd/yyyy HH:mm:ss")
                   !createby = Environ("Username")
                   R = R + 1
                .Update
                End With
                Else
                    For X = 1 To RS!NumberFrames
                    With TR
                    .AddNew
                    !absfrmnumb = R
                    !NumbFrames = RS!NumberFrames
                    !firstfr = RS!FirstFrame
                    !lastfr = RS!LastFrame
                    !extitle = RS!Title
                    !exClass = RS!Class
                    !labelphrase = "Frame " & X & " of " & RS!NumberFrames
                    !rptCreation = Format(Now(), "mm/dd/yyyy HH:mm:ss")
                    !createby = Environ("Username")
                    
                    .Update

                       End With
                       R = R + 1
                    Next X
                End If
      
          RS.MoveNext
    Loop
    DoCmd.OpenTable "tmpFrameLAbels", acViewNormal
    DoCmd.TransferSpreadsheet acExport, , "tmpFrameLabels", KeyVal("datapath") &     "FrameLabelMg" _
        & "_" & Format(Now(), "yyyy-mm-dd") & ".xlsx", True
    ' Use the XLSX file to create Mail-Merge
    MsgBox "Pickup the Label Merge files at " & KeyVal("datapath"), vbInformation, "Done"
End Sub

Some information deleted.