Private Sub btnGenerateExcelSheets_Click() Dim selectedAlbarans As String, folderSelected As String, pdfFileName As String, dictSupplier As Object, dictAlbaran As Object, messageBoxString, excelFileName As String, oExcel As Object, oExcelWrkBk As Object, oExcelWrSht As Object, bExcelOpened As Boolean Dim columnNumber As Integer, rowNumber As Integer, sheetNumber As Integer, totalOfKGsTotals As Double, totalOfestCashTotals As Double, totalOfactCashTotals As Double, OutApp As Object, OutMail As Object, suppAlbaranTitle As String Set dictSupplier = CreateObject("scripting.dictionary") Set dictAlbaran = CreateObject("scripting.dictionary") Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With Me.RecordsetClone ' validate customer is all the same for selected records If Not (.BOF And .EOF) Then .MoveFirst Do Until .EOF If Me.txtSelected Like "*," & ![cons_prod_id] & ",*" Then dictSupplier(CStr(![cons_supplier_id])) = dictSupplier(CStr(![cons_supplier_id])) + 1 If Me.txtSelected Like "*," & ![cons_prod_id] & ",*" Then dictAlbaran(CStr(![cons_albaran])) = dictAlbaran(CStr(![cons_albaran])) + 1 .MoveNext Loop End With For Each key In dictAlbaran.Keys selectedAlbarans = selectedAlbarans & ",'" & key & "'" Next key selectedAlbarans = trimSelection(selectedAlbarans) If dictSupplier.Count <> 1 Then ' if more than 1 supplier is selected then don't progress MsgBox "Please select only 1 Supplier and run again" Exit Sub End If folderSelected = BrowseFolder("Select Excel Storage Folder") If folderSelected = "" Then Exit Sub excelFileName = Format(Date, "yyyymmdd") & "-" & Format(Time, "hhmm") & "-Export.xlsx" On Error Resume Next Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one Err.Clear On Error GoTo Error_Handler Set oExcel = CreateObject("excel.application") bExcelOpened = False Else 'Excel was already running bExcelOpened = True End If On Error GoTo Error_Handler oExcel.ScreenUpdating = False oExcel.Visible = False 'Keep Excel hidden until we are done with our manipulation Set oExcelWrkBk = oExcel.Workbooks.Add() 'Start a new workbook Dim level1RS As DAO.Recordset, level1TotalLineRS As DAO.Recordset Dim level2RS As DAO.Recordset, level2TotalLineRS As DAO.Recordset Dim level1RSFiltered As DAO.Recordset Dim level1TotalLineRSFiltered As DAO.Recordset Dim level2RSFiltered As DAO.Recordset Dim level2TotalLineRSFiltered As DAO.Recordset Debug.Print fOpenDatabaseCount strLevel1SQL = Replace(Left(CurrentDb.QueryDefs("qryReturnsExcelSheetsLevel1").SQL, Len(CurrentDb.QueryDefs("qryReturnsExcelSheetsLevel1").SQL) - 3), "ORDER BY", "WHERE [FACT-Consignments].cons_albaran In (" & selectedAlbarans & ") ORDER BY") Set level1RS = CurrentDb.OpenRecordset(strLevel1SQL) Debug.Print fOpenDatabaseCount strLevel1TotalLineSQL = Replace(Left(CurrentDb.QueryDefs("qryReturnsExcelSheetsLevel1TotalLine").SQL, Len(CurrentDb.QueryDefs("qryReturnsExcelSheetsLevel1TotalLine").SQL) - 3), "ORDER BY", "HAVING [FACT-Consignments].cons_albaran In (" & selectedAlbarans & ") ORDER BY") Set level1TotalLineRS = CurrentDb.OpenRecordset(strLevel1TotalLineSQL) Debug.Print fOpenDatabaseCount strLevel2SQL = Replace(Left(CurrentDb.QueryDefs("qryReturnsExcelSheetsLevel2").SQL, Len(CurrentDb.QueryDefs("qryReturnsExcelSheetsLevel2").SQL) - 3), "WHERE ((([FACT-Deliveries].del_rejected_del_id) Is Null))", "WHERE [FACT-Deliveries].del_rejected_del_id) Is Null And [FACT-Consignments].cons_albaran In (" & selectedAlbarans & ") ") Set level2RS = CurrentDb.OpenRecordset(strLevel2SQL) Debug.Print fOpenDatabaseCount ' strLevel2TotalLineSQL = Replace(Left(CurrentDb.QueryDefs("qryReturnsExcelSheetsLevel2TotalLine").SQL, Len(CurrentDb.QueryDefs("qryReturnsExcelSheetsLevel2TotalLine").SQL) - 3), "ORDER BY", "HAVING [qryReturnsExcelSheetsLevel2].[Supplier Ref] In (" & selectedAlbarans & ") ORDER BY") ' Set level2TotalLineRS = CurrentDb.OpenRecordset(strLevel2TotalLineSQL) sheetNumber = 1: totalOfKGsTotals = 0: totalOfestCashTotals = 0: totalOfactCashTotals = 0 For Each suppAlbaran In Split(selectedAlbarans, ",") 'suppAlbaran = Right(suppAlbaran, Len(suppAlbaran) - 1): suppAlbaran = Left(suppAlbaran, Len(suppAlbaran) - 1) level1RS.Filter = "[Supplier Ref] = " & suppAlbaran: Set level1RSFiltered = level1RS.OpenRecordset ' filter the queried recordset for only therecords relating to the supplier ref suppAlbaranTitle = Right(suppAlbaran, Len(suppAlbaran) - 1): suppAlbaranTitle = Left(suppAlbaranTitle, Len(suppAlbaranTitle) - 1) level1RSFiltered.MoveLast: level1RSFiltered.MoveFirst If Not level1RSFiltered.BOF And Not level1RSFiltered.EOF Then ' if there are records Set oExcelWrSht = oExcelWrkBk.Sheets(sheetNumber) oExcelWrSht.Name = fStripIllegal(CStr(suppAlbaranTitle)) oExcelWrSht.Cells(1, 1).Value = "Supplier" ' output the supplier name and reference numbers only 1 time instead for each line oExcelWrSht.Cells(1, 2).Value = "Supplier Ref" With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), oExcelWrSht.Cells(1, 2)) .Font.Bold = True .Font.ColorIndex = 2 .Interior.ColorIndex = 1 .HorizontalAlignment = xlCenter End With oExcelWrSht.Cells(2, 1).Value = level1RSFiltered![Supplier] oExcelWrSht.Cells(2, 2).Value = level1RSFiltered![Supplier Ref] rowNumber = 4: columnNumber = 1 For Each fld In level1RSFiltered.Fields If fld.Name <> "Supplier" And fld.Name <> "Supplier Ref" Then oExcelWrSht.Cells(rowNumber, columnNumber).Value = fld.Name columnNumber = columnNumber + 1 End If Next With oExcelWrSht.Range(oExcelWrSht.Cells(rowNumber, 1), oExcelWrSht.Cells(rowNumber, columnNumber - 1)) ' highlight the header cells with black background and white text with bold font and centered in the cell .Font.Bold = True .Font.ColorIndex = 2 .Interior.ColorIndex = 1 .HorizontalAlignment = xlCenter End With rowNumber = rowNumber + 1 While (Not level1RSFiltered.EOF) columnNumber = 1 For Each fld In level1RSFiltered.Fields If fld.Name <> "Supplier" And fld.Name <> "Supplier Ref" Then oExcelWrSht.Cells(rowNumber, columnNumber).Value = fld.Value columnNumber = columnNumber + 1 End If Next rowNumber = rowNumber + 1 level1RSFiltered.MoveNext Wend level1TotalLineRS.Filter = "[Supplier Ref] = " & suppAlbaran: Set level1TotalLineRSFiltered = level1TotalLineRS.OpenRecordset ' filter the queried recordset for only therecords relating to the supplier ref level1TotalLineRSFiltered.MoveLast: level1TotalLineRSFiltered.MoveFirst If Not level1TotalLineRSFiltered.BOF And Not level1TotalLineRSFiltered.EOF Then ' if there are records totalOfKGsTotals = totalOfKGsTotals + level1TotalLineRSFiltered!KGs totalOfestCashTotals = totalOfestCashTotals + level1TotalLineRSFiltered![Est Cash Total] totalOfactCashTotals = totalOfactCashTotals + level1TotalLineRSFiltered![Act Cash Total] columnNumber = 1 For Each fld In level1TotalLineRSFiltered.Fields If fld.Name <> "Supplier" And fld.Name <> "Supplier Ref" Then oExcelWrSht.Cells(rowNumber, columnNumber).Value = fld.Value If Nz(fld.Value, 9999) <> 9999 And fld.Value <> " " And fld.Value <> "" Then With oExcelWrSht.Range(oExcelWrSht.Cells(rowNumber, columnNumber), oExcelWrSht.Cells(rowNumber, columnNumber)) .Font.Bold = True .Interior.ColorIndex = 37 End With End If columnNumber = columnNumber + 1 End If Next End If level1TotalLineRSFiltered.Close: Set level1TotalLineRSFiltered = Nothing rowNumber = rowNumber + 2 ' increment the line numbers by one to leave a gap between level 1 and level 2 level2RS.Filter = "[Supplier Ref] = " & suppAlbaran: Set level2RSFiltered = level2RS.OpenRecordset level2RSFiltered.MoveLast: level2RSFiltered.MoveFirst If Not level2RSFiltered.BOF And Not level2RSFiltered.EOF Then columnNumber = 1 For Each fld In level2RSFiltered.Fields If fld.Name <> "cons_prod_id" And fld.Name <> "del_prod_id" And fld.Name <> "Supplier" And fld.Name <> "Supplier Ref" Then oExcelWrSht.Cells(rowNumber, columnNumber).Value = fld.Name columnNumber = columnNumber + 1 End If Next With oExcelWrSht.Range(oExcelWrSht.Cells(rowNumber, 1), oExcelWrSht.Cells(rowNumber, columnNumber - 1)) ' highlight the header cells with black background and white text with bold font and centered in the cell .Font.Bold = True .Font.ColorIndex = 2 .Interior.ColorIndex = 1 .HorizontalAlignment = xlCenter End With rowNumber = rowNumber + 1 While (Not level2RSFiltered.EOF) columnNumber = 1 For Each fld In level2RSFiltered.Fields If fld.Name <> "cons_prod_id" And fld.Name <> "del_prod_id" And fld.Name <> "Supplier" And fld.Name <> "Supplier Ref" Then oExcelWrSht.Cells(rowNumber, columnNumber).Value = fld.Value columnNumber = columnNumber + 1 End If Next rowNumber = rowNumber + 1 level2RSFiltered.MoveNext Wend End If level2RSFiltered.Close: Set level2RSFiltered = Nothing 'level2TotalLineRS.Filter = "[Supplier Ref1] = " & suppAlbaran: Set level2TotalLineRSFiltered = level2TotalLineRS.OpenRecordset 'level2TotalLineRSFiltered.MoveLast: level2TotalLineRSFiltered.MoveFirst 'If Not level2TotalLineRSFiltered.BOF And Not level2TotalLineRSFiltered.EOF Then ' if there are records 'columnNumber = 1 'For Each fld In level2TotalLineRSFiltered.Fields 'If fld.Name <> "Supplier1" And fld.Name <> "Supplier Ref1" Then 'oExcelWrSht.Cells(rowNumber, columnNumber).Value = fld.Value 'If Nz(fld.Value, 9999) <> 9999 And fld.Value <> " " And fld.Value <> "" Then 'With oExcelWrSht.Range(oExcelWrSht.Cells(rowNumber, columnNumber), oExcelWrSht.Cells(rowNumber, columnNumber)) '.Font.Bold = True '.Interior.ColorIndex = 37 'End With 'End If 'columnNumber = columnNumber + 1 'End If 'Next 'End If 'level2TotalLineRSFiltered.Close: Set level2TotalLineRSFiltered = Nothing oExcelWrSht.Range(oExcelWrSht.Cells(1, 3), oExcelWrSht.Cells(oExcelWrSht.UsedRange.Rows.Count, oExcelWrSht.UsedRange.Columns.Count)).NumberFormat = "0.00" ' select range of cells that do not include the first 2 columns a s they have dates in them, this then applies a number format to those cells oExcelWrSht.Select ' now select everything and apply a new font size and auto fit the columns so it looks neat and tidy oExcelWrSht.Cells.Font.size = 9 oExcelWrSht.Cells.EntireColumn.AutoFit Set oExcelWrSht = oExcelWrkBk.Sheets.Add(After:=oExcelWrkBk.Sheets(sheetNumber)) ' create a new sheet and increment the sheet numbers sheetNumber = sheetNumber + 1 End If level1RSFiltered.Close: Set level1RSFiltered = Nothing Next suppAlbaran Set oExcelWrSht = oExcelWrkBk.Sheets(sheetNumber) oExcelWrSht.Name = "Summary" oExcelWrSht.Cells(1, 1).Value = "Summary Of All Consignments:" oExcelWrSht.Cells(2, 1).Value = "Total KGs" oExcelWrSht.Cells(3, 1).Value = "Total Estimated Cash" oExcelWrSht.Cells(4, 1).Value = "Total Estimated Cash/KGs" oExcelWrSht.Cells(5, 1).Value = "Total Actual Cash" oExcelWrSht.Cells(6, 1).Value = "Total Actual Cash/KGs" With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), oExcelWrSht.Cells(6, 1)) .Font.Bold = True .Font.ColorIndex = 2 .Interior.ColorIndex = 1 .HorizontalAlignment = xlCenter End With oExcelWrSht.Cells(2, 2).Value = totalOfKGsTotals oExcelWrSht.Cells(3, 2).Value = totalOfestCashTotals oExcelWrSht.Cells(4, 2).Value = totalOfestCashTotals / totalOfKGsTotals oExcelWrSht.Cells(5, 2).Value = totalOfactCashTotals oExcelWrSht.Cells(6, 2).Value = totalOfactCashTotals / totalOfKGsTotals oExcelWrSht.Select oExcelWrSht.Cells.NumberFormat = "0.00" oExcelWrSht.Cells.Font.size = 9 oExcelWrSht.Cells.EntireColumn.AutoFit oExcelWrkBk.Sheets(1).Select 'Go back to the first sheet oExcelWrkBk.Close True, excelFileName 'Save and close the generated workbook If bExcelOpened = False Then oExcel.Quit 'Close excel if is wasn't originally running level1RS.Close: Set level1RS = Nothing level1TotalLineRS.Close: Set level1TotalLineRS = Nothing level2RS.Close: Set level2RS = Nothing level2TotalLineRS.Close: Set level2TotalLineRS = Nothing Set oExcelWrSht = Nothing: Set oExcelWrkBk = Nothing: Set oExcel = Nothing messageBoxString = "Sheet creation complete: " & vbNewLine & vbNewLine & "Folder: " & vbNewLine & " " & folderSelected & vbNewLine & vbNewLine & "Filename: " & vbNewLine & " " & excelFileName & vbNewLine & vbNewLine & "Would you like to open the export file?" If MsgBox(messageBoxString, vbQuestion + vbYesNo + vbDefaultButton2, "Open File?") = vbYes Then OpenFile (folderSelected & "\" & excelFileName) Exit Sub Error_Handler_Exit: On Error Resume Next oExcel.Visible = True 'Make excel visible to the user Set oExcelWrSht = Nothing: Set oExcelWrkBk = Nothing: oExcel.ScreenUpdating = True: Set oExcel = Nothing level1RS.Close: Set level1RS = Nothing level1RSFiltered.Close: Set level1RSFiltered = Nothing level1TotalLineRS.Close: Set level1TotalLineRS = Nothing level1TotalLineRSFiltered.Close: Set level1TotalLineRSFiltered = Nothing level2RS.Close: Set level2RS = Nothing level2RSFiltered.Close: Set level2RSFiltered = Nothing level2TotalLineRS.Close: Set level2TotalLineRS = Nothing 'level2TotalLineRSFiltered.Close: Set level2TotalLineRSFiltered = Nothing Exit Sub Error_Handler: MsgBox "The following error has occured" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: Export2XLS" & vbCrLf & _ "Error Description: " & Err.Description _ , vbOKOnly + vbCritical, "An Error has Occured!" Resume Error_Handler_Exit End Sub