Untitled
Private Sub UserForm_Initialize() ' Initialize the user form and populate dropdown and list boxes Call PopulateOptions End Sub Private Sub optCountry_Click() ' Refresh options when Country is selected Call PopulateOptions End Sub Private Sub optStandard_Click() ' Refresh options when Standard is selected Call PopulateOptions End Sub Private Sub PopulateOptions() ' Populates dropdown and list boxes based on the selected option (Country/Standard) Dim ws As Worksheet Dim i As Long Dim uniqueDomains As Object Dim uniquePriorities As Object Dim lastRow As Long Set ws = ThisWorkbook.Sheets("Integrated Control sheet") Set uniqueDomains = CreateObject("Scripting.Dictionary") Set uniquePriorities = CreateObject("Scripting.Dictionary") ' Clear existing options Me.cmbOptions.Clear Me.lstDomain.Clear Me.lstRiskPriority.Clear ' Populate dropdown with Country or Standard options If Me.optCountry.Value Then For i = 5 To 21 ' Columns E to U for countries If ws.Cells(2, i).Value <> "" Then Me.cmbOptions.AddItem ws.Cells(2, i).Value Next i ElseIf Me.optStandard.Value Then For i = 22 To 29 ' Columns V to AC for standards If ws.Cells(2, i).Value <> "" Then Me.cmbOptions.AddItem ws.Cells(2, i).Value Next i End If ' Populate unique Domains (Column A) lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row For i = 4 To lastRow If ws.Cells(i, 1).Value <> "" Then uniqueDomains(ws.Cells(i, 1).Value) = True Next i For Each key In uniqueDomains.Keys Me.lstDomain.AddItem key Next key ' Populate unique Risk Priorities (Column AR) For i = 4 To lastRow If ws.Cells(i, 44).Value <> "" Then uniquePriorities(ws.Cells(i, 44).Value) = True Next i For Each key In uniquePriorities.Keys Me.lstRiskPriority.AddItem key Next key End Sub Private Sub btnGenerateReport_Click() ' Main logic for generating the report based on filters Dim wsMain As Worksheet Dim wsReport As Worksheet Dim lastRow As Long, reportRow As Long Dim selectedOption As String Dim selectedDomains As Object, selectedPriorities As Object Dim startCol As Long, endCol As Long Dim i As Long, j As Long Dim newFileName As String Set wsMain = ThisWorkbook.Sheets("Integrated Control sheet") Set wsReport = ThisWorkbook.Sheets("Report Sheet") ' Get selected option from dropdown selectedOption = Me.cmbOptions.Value If selectedOption = "" Then MsgBox "Please select an option from the dropdown.", vbExclamation Exit Sub End If ' Store selected filters in dictionaries Set selectedDomains = CreateObject("Scripting.Dictionary") Set selectedPriorities = CreateObject("Scripting.Dictionary") For i = 0 To Me.lstDomain.ListCount - 1 If Me.lstDomain.Selected(i) Then selectedDomains(Me.lstDomain.List(i)) = True Next i For i = 0 To Me.lstRiskPriority.ListCount - 1 If Me.lstRiskPriority.Selected(i) Then selectedPriorities(Me.lstRiskPriority.List(i)) = True Next i ' Identify column range for the selected option (Country or Standard) If Me.optCountry.Value Then For j = 5 To 21 ' Columns E to U If wsMain.Cells(2, j).Value = selectedOption Then startCol = j endCol = j Exit For End If Next j ElseIf Me.optStandard.Value Then For j = 22 To 29 ' Columns V to AC If wsMain.Cells(2, j).Value = selectedOption Then startCol = j endCol = j Exit For End If Next j End If If startCol = 0 Or endCol = 0 Then MsgBox "Option not found in the headers.", vbExclamation Exit Sub End If ' Clear the Report Sheet and copy headers wsReport.Cells.Clear wsMain.Rows(1).Copy Destination:=wsReport.Rows(1) ' Generate filtered data for the report lastRow = wsMain.Cells(wsMain.Rows.Count, 1).End(xlUp).Row reportRow = 4 For i = 4 To lastRow If (selectedDomains.Count = 0 Or selectedDomains.exists(wsMain.Cells(i, 1).Value)) And _ (selectedPriorities.Count = 0 Or selectedPriorities.exists(wsMain.Cells(i, 44).Value)) Then ' Copy row if filters match wsMain.Range(wsMain.Cells(i, 1), wsMain.Cells(i, endCol)).Copy _ Destination:=wsReport.Cells(reportRow, 1) reportRow = reportRow + 1 End If Next i ' Remove rows where selected columns are blank Call RemoveBlankRows(wsReport, startCol, endCol) ' Prompt user to save the report newFileName = Application.GetSaveAsFilename(InitialFileName:="Generated_Report.xlsx", FileFilter:="Excel Files (*.xlsx), *.xlsx") If newFileName <> "False" Then wsReport.Parent.SaveAs newFileName, FileFormat:=xlOpenXMLWorkbook MsgBox "Report generated successfully!", vbInformation Else MsgBox "Report generation canceled.", vbExclamation End If End Sub Private Sub RemoveBlankRows(ws As Worksheet, startCol As Long, endCol As Long) ' Removes rows where the selected columns are blank Dim lastRow As Long Dim i As Long lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row For i = lastRow To 4 Step -1 If WorksheetFunction.CountA(ws.Range(ws.Cells(i, startCol), ws.Cells(i, endCol))) = 0 Then ws.Rows(i).Delete End If Next i End Sub
Leave a Comment