Private Function ExcelSheetPopulate(ByRef appXL As Excel.Application, _ ByRef wSht As Excel.Worksheet, _ ByVal lngXLLID As Long, _ ByVal strQuery As String, _ Optional ByRef lngRecsOut As Long = 0, _ Optional ByVal binFailOnNoData As Boolean = True, _ Optional ByVal binMsgOnNoData As Boolean = True) As Boolean 'Populate Excel sheet from query and format per tblExcelLayouts, tblExcelDetail Dim strFormatSql As String Dim strDataSql As String Dim dbS As DAO.Database Dim rsFormats As DAO.Recordset Dim rsData As DAO.Recordset Dim intCol As Integer Dim strNumberFormat As String Dim strXldFieldName As String Dim curXldColWidth As Currency Dim qdF As QueryDef Dim strAlias As String Dim strFormula As String Dim strMissingFields As String Dim arMissingFields() As String Dim binMissing As Boolean Dim strQdfSql As String Dim binRet As Boolean 10 On Error GoTo ErrLine 20 Call ProcStackPush("modExcel.ExcelSheetPopulate") 30 Set dbS = CurrentDb 40 strFormatSql = "SELECT tblExcelLayouts.XllZoom, tblExcelLayouts.XllFreezeTopRow, tblExcelLayouts.XllAutofitSheet, " _ & "tblExcelDetail.XldFieldName, tblExcelDetail.XldColHead, tblExcelDetail.XldColWidth, " _ & "tblExcelDetail.XldColOrder, tblExcelDetail.XldFormat, tblExcelDetail.XldColAlignment, " _ & "tblExcelDetail.XldAddBlank, tblExcelDetail.XldAddSum, tblExcelDetail.XldSumFunction, " _ & "tblExcelStyles.XlstStyle AS XllHeaderCellStyle, tblExcelStyles_1.XlstStyle AS XllSumCellStyle " _ & "FROM ((tblExcelLayouts INNER JOIN tblExcelDetail ON tblExcelLayouts.XLLID = tblExcelDetail.XldXLLID) " _ & "LEFT JOIN tblExcelStyles ON tblExcelLayouts.XllHeaderCellXLSTYID = tblExcelStyles.XLSTYID) " _ & "LEFT JOIN tblExcelStyles AS tblExcelStyles_1 ON tblExcelLayouts.XllSumCellXLSTYID = tblExcelStyles_1.XLSTYID " _ & "WHERE tblExcelLayouts.XLLID = " & lngXLLID & " AND tblExcelDetail.XldInclude = True " _ & " ORDER BY tblExcelDetail.XldColOrder;" 50 Set rsFormats = dbS.OpenRecordset(strFormatSql, dbOpenSnapshot) 60 If Not rsFormats.EOF Then 70 Set qdF = CurrentDb.QueryDefs(strQuery) 80 strQdfSql = qdF.SQL 90 If Not qdF.Fields.Count > 0 Then 100 Err.Raise -50000, "modExcel.ExcelSheetPopulate", strQuery & " has no fields." 110 GoTo ExitLine 120 End If 130 With wSht 140 .Activate 150 intCol = 0 160 Do While Not rsFormats.EOF 170 strAlias = "" 180 binMissing = False 190 If QueryDefFieldExists(qdF, rsFormats!XldFieldName, strAlias) Then 200 strDataSql = strDataSql & ", " & rsFormats!XldFieldName 210 strAlias = Nz(rsFormats!XldColHead, strAlias) 'First take alias from XldColHead, then query field Description 220 If strAlias <> "" And strAlias <> rsFormats!XldFieldName Then 230 strDataSql = strDataSql & " AS [" & strAlias & "]" 240 End If 250 ElseIf rsFormats!XldAddBlank = True Then 260 strAlias = Nz(rsFormats!XldColHead, rsFormats!XldFieldName) 270 strDataSql = strDataSql & ", NULL AS [" & strAlias & "]" 280 Else '9/30/2020 290 strMissingFields = AddStringsWithSeparator(strMissingFields, rsFormats!XldFieldName, ",") 300 binMissing = True 310 End If 320 If Not binMissing Then 330 intCol = intCol + 1 340 .Cells(1, intCol).Value = DefaultIfNoValue(strAlias, rsFormats!XldFieldName) 'Column Head 350 End If 360 rsFormats.MoveNext 370 Loop 380 strDataSql = "SELECT " & Mid(strDataSql, 2) & " FROM " & strQuery 390 Set rsData = dbS.OpenRecordset(strDataSql, dbOpenSnapshot) 400 If rsData.EOF Then 410 If binMsgOnNoData Then 420 MsgBox "Sorry, no data for " & wSht.NAME & ".", vbInformation 430 End If 440 binRet = Not binFailOnNoData 450 GoTo ExitLine 460 End If 470 .Range("A2").CopyFromRecordset rsData 'Insert the data 480 lngRecsOut = rsData.RecordCount 490 rsFormats.MoveFirst 500 intCol = 0 510 arMissingFields = Split(strMissingFields, ",") 520 Do While Not rsFormats.EOF 'Format columns 530 If Not ArrayItemIndex(arMissingFields, rsFormats!XldFieldName) > -1 Then 540 intCol = intCol + 1 550 strXldFieldName = rsFormats!XldFieldName 560 curXldColWidth = Nz(rsFormats!XldColWidth, -1) 570 If curXldColWidth = -1 Then 580 .Columns(intCol).AutoFit 590 Else 600 .Columns(intCol).ColumnWidth = curXldColWidth 610 End If 620 strNumberFormat = Nz(rsFormats!XldFormat, "General") 630 .Columns(intCol).NumberFormat = strNumberFormat 640 .Columns(intCol).HorizontalAlignment = CInt(Nz(rsFormats!XldColAlignment, XlHAlign.xlHAlignGeneral)) 650 If rsFormats!XldAddSum = True Then 660 Select Case rsData.Fields(intCol - 1).Type Case dbByte, dbCurrency, dbDecimal, dbDouble, dbFloat, dbInteger, dbLong, dbNumeric, dbSingle 670 strFormula = "=" & Nz(rsFormats!XldSumFunction, "SUM") _ & "(R2C" & intCol & ":R" & lngRecsOut + 1 & "C" & intCol & ")" ' 680 .Cells(lngRecsOut + 2, intCol).FormulaR1C1 = strFormula 690 If Not NoValue(rsFormats!XllSumCellStyle) Then 700 .Cells(lngRecsOut + 2, intCol).style = rsFormats!XllSumCellStyle 710 End If 720 Case Else 'do nothing 730 End Select 740 End If 750 End If 760 rsFormats.MoveNext 770 Loop 780 End With 790 rsFormats.MoveLast 'Format sheet 800 If Nz(rsFormats!XllZoom, 0) > 0 Then 810 appXL.ActiveWindow.Zoom = rsFormats!XllZoom 820 End If 830 If Not NoValue(rsFormats!XllHeaderCellStyle) Then 840 wSht.Rows(1).style = rsFormats!XllHeaderCellStyle 850 End If 860 If rsFormats!XllAutofitSheet = True Then 870 wSht.UsedRange.Columns.AutoFit 880 End If 890 wSht.UsedRange.WrapText = True 900 wSht.Rows(1).VerticalAlignment = XlVAlign.xlVAlignTop 910 If rsFormats!XllFreezeTopRow = True Then 920 wSht.Rows(2).Select 930 appXL.ActiveWindow.FreezePanes = True 940 wSht.Cells(1).Select 950 End If 960 binRet = True 970 Else 980 MsgBox "Excel layout not found.", vbExclamation, "Excel Sheet Populate" 990 End If ExitLine: 1000 On Error Resume Next 1010 ExcelSheetPopulate = binRet 1020 Call DestroyDbObject(rsData) 1030 Call DestroyDbObject(rsFormats) 1040 Call DestroyDbObject(dbS) 1050 Set qdF = Nothing 1060 Call ProcStackPop 1070 Exit Function ErrLine: 1080 If Err.Number <> ERN.COMMAND_CANCELLED And Err.Number <> ERN.NO_CURRENT_RECORD Then 1090 Call ReportError("modExcel.ExcelSheetPopulate", "lngXLLID: " & lngXLLID & vbCrLf & "strQuery: " & strQuery _ & vbCrLf & "strFormatSql: " & strFormatSql & vbCrLf & "strDataSql: " & strDataSql _ & vbCrLf & "mstrFile: " & mstrFile & vbCrLf & "strQdfSql: " & strQdfSql) 1100 End If 1110 Resume ExitLine End Function