I have an Excel form that has nearly 500 questions/answers. Those answers are stored in a series of tables in Access. I need to be able to export to Excel and fill specific ranges. I have demonstrated it can work with a small query, but Access is limited to 255 fields. If I combine all the fields, I exceed the Access limitation. (Yes it is a poor design and I inherited this recently.) How can I combine multiple queries to go to the right cell locations in the same Excel document? The code below works, but I am unaware of a way to concatenate, combine or whatever it may be called. Also, I have commented out the "ActiveSheet.OLEObjects", but if you know how to export a value to dropdown or checkbox, I would appreciate the help with this too. This form should be editable after it is export. The user should be able to change the values and return to be uploaded again. Sorry, I cannot upload the database since it has military information (unclassified but FOUO). My main concern is to understand how to combine the results of multiple queries to the same sheet.
Code:
Private Sub Btn_ExportPlatform_Click() Const msoFileDialogFilePicker As Long = 4
Dim FD As Object
Dim file As Variant
Dim fileName As String, fldrPath As String, filePath As String
Dim answer As Integer
Dim curPath As String
'Declare DAO objects
Dim db As dao.Database
Dim rs As dao.Recordset
Dim strSQL As String
Dim strSelect As String 'Used for tables 1-3
Dim strSelect2 As String 'Use for table 4
Dim strFileLocation As String
Dim strFileName As String
Dim SelObj As Variant
Dim PlatformTIdForFilename, ReportingOrgForFilename, TheOutputFileName As String
Dim DateForFilename, TimeForFilename As String
DateForFilename = Format(Now(), "_yyyy_mm_dd")
TimeForFilename = Format(Now(), "_hhmmss")
strFileName = "Questionaire_APNT.xlsx"
' strSelect = GetSelectAPNTPlatformExport()
' Use this code to check if a file location has been stored. If it has, provide a prompt to update or remain the same.
strSQL = " SELECT ADMIN.THE_VALUE " _
& " FROM ADMIN " _
& " WHERE ADMIN.ADMIN_ID = " & 3
Set rs = CurrentDb.OpenRecordset(strSQL)
If IsNull(rs![THE_VALUE]) Then
'Append file location to "ADMIN" table
MsgBox "Please select the Excel Questionnaire Template location when the next dialog box opens.", vbOKOnly, "Template Location Notification"
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.Title = "Please select a template folder"
End With
' On Error GoTo invalidFolderPath
If FD.Show = -1 Then
'Debug.Print FD.SelectedItems(1) 'Used to test folder location
'fileName = "SOME Questionnaire_" & Format(Date, "yyyy-mm-dd") 'filename & date when report was run*
fldrPath = FD.SelectedItems(1)
DoCmd.SetWarnings False
'When transferring to SIPR, remember to add row '3' or whatever number is listed. Without this, the code will fail.
DoCmd.RunSQL "Update ADMIN SET ADMIN.THE_VALUE = ('" & fldrPath & "')" _
& " WHERE ADMIN.ADMIN_ID = " & 3
DoCmd.SetWarnings True
MsgBox "File Location: " & fldrPath & " - Successful!" & vbCrLf & vbCrLf & "The export process may take a few moments. Please be patient.", vbOKOnly, "Updated Location"
'Code to actually export form goes below here.
strSelect = GetSelectAPNTPlatformExport()
'Declare Excel objects
Dim xlApp As Object, wkbk As Object, wks As Object, ActiveSheet As Object
Set db = CurrentDb
Set rs = db.OpenRecordset(strSelect)
rs.MoveFirst
Do While Not rs.EOF
' On Error GoTo ErrorHandler
'Open workbook
Set xlApp = CreateObject("Excel.Application")
xlApp.Quit
With xlApp
.Visible = False
'GetSelectAPNTPlatformExport (rs)
Set wkbk = .Workbooks.Open(fldrPath & "\" & strFileName, True, False)
'Debug.Print fldrPath & "\" & strFileName
'Format worksheet
Set wks = wkbk.worksheets(1)
With wks
'Section 1. Classification Level & POC information
.Range("U1") = rs!PLATFORM_T_ID ' PLATFORM_T_ID
' ActiveSheet.OLEObjects("Cbo_Classification").Object.Text = wkbk.worksheets(1).FORM_CLASSIFICATION 'Banner Form Classification
' ActiveSheet.OLEObjects("Cbo_RptOrg").Object.Text = wkbk.worksheets(1).REPORTING_ORG '1.01 Reporting Organization
.Range("K12") = rs!OFFICE_SYMBOL ' OFFICE_SYMBOL
.Range("K13") = rs!PF_Name ' Primary Contact_FName
.Range("K14") = rs!PL_Name ' Primary Contact_LName
.Range("K15") = rs!P_Position ' Primary Contact_Position
.Range("K16") = rs!P_Phone ' Primary Contact_Phone
.Range("K17") = rs!P_Email ' Contact_Email
.Range("K18") = rs!P_AddEmail ' Primary Additional Email
.Range("K19") = rs!TF_Name ' Technical Contact_FName
.Range("K20") = rs!TL_Name ' Technical Contact_LName
.Range("K21") = rs!T_Position ' Technical Contact_Position
.Range("K22") = rs!T_Phone ' Technical Contact_Phone
.Range("K23") = rs!T_Email ' Technical Contact_Email
.Range("K24") = rs!T_AddEmail ' Technical Additional Email
.Range("K25") = rs!AF_Name ' Additional Contact_FName
.Range("K26") = rs!AL_Name ' Additional Contact_LName
.Range("K27") = rs!A_Position ' Additional Contact_Position
.Range("K28") = rs!A_Phone ' Additional Contact_Phone
.Range("K29") = rs!A_Email ' Additional Contact_Email
.Range("K30") = rs!A_AddEmail ' Additional Contact/Additional Email
'
' 'Section 2. Point of Contact (POC) Information
.Range("K33") = rs!SYSTEM_NOM 'SYSTEM NOM
.Range("K34") = rs!VARIANT_NAME ' "VARIANT_NAME
.Range("K35") = rs!COMMON_NAME ' "COMMON_NAME