Untitled
Private Sub btnGenerateReport_Click() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim wbNew As Workbook Dim lastRow As Long Dim selectedOption As String Dim selectedDomains As Object Dim selectedRiskPriorities As Object Dim i As Long, j As Long Dim reportRow As Long Dim startCol As Long, endCol As Long Dim headerRange As Range Dim optionFound As Boolean Dim newFileName As String Set wsMain = ThisWorkbook.Sheets("Integrated Control sheet") Set wsReport = ThisWorkbook.Sheets("Report Sheet") ' Create dictionaries for selected filters Set selectedDomains = CreateObject("Scripting.Dictionary") Set selectedRiskPriorities = CreateObject("Scripting.Dictionary") wsReport.Cells.Clear ' Clear the Report Sheet ' Get selected combo box value (Country or Standard) selectedOption = Me.cmbOptions.Value If selectedOption = "" Then MsgBox "Please select an option from the dropdown.", vbExclamation Exit Sub End If ' Add selected domains to the dictionary For i = 0 To Me.lstDomain.ListCount - 1 If Me.lstDomain.Selected(i) Then selectedDomains.Add Me.lstDomain.List(i), True End If Next i ' Add selected risk priorities to the dictionary For i = 0 To Me.lstRiskPriority.ListCount - 1 If Me.lstRiskPriority.Selected(i) Then selectedRiskPriorities.Add Me.lstRiskPriority.List(i), True End If Next i optionFound = False If Me.optCountry.Value Then ' Handle Country-specific logic Set headerRange = wsMain.Rows(2).Find(What:=selectedOption, LookIn:=xlValues, LookAt:=xlWhole) If headerRange Is Nothing Then MsgBox "Country not found!", vbExclamation Exit Sub End If startCol = headerRange.Column endCol = headerRange.MergeArea.Columns.Count + startCol - 1 optionFound = True ElseIf Me.optStandard.Value Then ' Handle Standard-specific logic For j = 22 To 29 ' Columns V to AC If wsMain.Cells(2, j).Value = selectedOption Or wsMain.Cells(3, j).Value = selectedOption Then startCol = j endCol = j optionFound = True Exit For End If Next j If Not optionFound Then MsgBox "Standard not found in the headers!", vbExclamation Exit Sub End If End If ' Copy general headers (A:D) wsMain.Range("A1:D3").Copy Destination:=wsReport.Range("A1") ' Copy selected Country or Standard-specific headers wsMain.Range(wsMain.Cells(1, startCol), wsMain.Cells(3, endCol)).Copy _ Destination:=wsReport.Cells(1, 5) ' Copy additional headers (AD:BB) wsMain.Range(wsMain.Cells(1, 30), wsMain.Cells(3, 54)).Copy _ Destination:=wsReport.Cells(1, 5 + (endCol - startCol + 1)) ' Generate the report based on selected filters lastRow = wsMain.Cells(wsMain.Rows.Count, 1).End(xlUp).Row reportRow = 4 ' Start writing data from row 4 in the Report Sheet For i = 4 To lastRow ' Check if the row matches the selected filters If (selectedDomains.exists(wsMain.Cells(i, 1).Value) Or selectedDomains.Count = 0) And _ (selectedRiskPriorities.exists(wsMain.Cells(i, 44).Value) Or selectedRiskPriorities.Count = 0) Then ' Copy general data (A:D) wsMain.Range(wsMain.Cells(i, 1), wsMain.Cells(i, 4)).Copy _ Destination:=wsReport.Cells(reportRow, 1) ' Copy data for selected Country or Standard wsMain.Range(wsMain.Cells(i, startCol), wsMain.Cells(i, endCol)).Copy _ Destination:=wsReport.Cells(reportRow, 5) ' Copy additional data (AD:BB) wsMain.Range(wsMain.Cells(i, 30), wsMain.Cells(3, 54)).Copy _ Destination:=wsReport.Cells(reportRow, 5 + (endCol - startCol + 1)) reportRow = reportRow + 1 End If Next i ' Now, call FilterAndRemoveBlankRows from Module 2 (Filter rows based on the country columns) Call FilterAndRemoveBlankRows ' Create a new workbook and copy the report Set wbNew = Application.Workbooks.Add wsReport.Copy Before:=wbNew.Sheets(1) ' Name the new worksheet appropriately wbNew.Sheets(1).Name = "Generated Report" ' Prompt user for file name newFileName = Application.GetSaveAsFilename(InitialFileName:="Generated_Report.xlsx", FileFilter:="Excel Files (*.xlsx), *.xlsx") If newFileName <> "False" Then wbNew.SaveAs newFileName, FileFormat:=xlOpenXMLWorkbook MsgBox "Report generated and saved successfully!", vbInformation Else MsgBox "Report generation canceled.", vbExclamation End If wbNew.Close SaveChanges:=False ' Close the new workbook if not saved Unload Me End Sub
Leave a Comment