Untitled
Private Sub UserForm_Initialize() Call PopulateOptions End Sub Private Sub optCountry_Click() Call PopulateOptions End Sub Private Sub optStandard_Click() Call PopulateOptions End Sub Private Sub PopulateOptions() Dim ws As Worksheet Dim i As Long Dim uniqueDomains As Object, uniqueRiskPriorities As Object Set ws = ThisWorkbook.Sheets("Integrated Control sheet") Set uniqueDomains = CreateObject("Scripting.Dictionary") Set uniqueRiskPriorities = CreateObject("Scripting.Dictionary") ' Clear existing items Me.cmbOptions.Clear Me.lstDomain.Clear Me.lstRiskPriority.Clear ' Populate options based on selection If Me.optCountry.Value Then ' Populate ComboBox with countries (Columns E to U) For i = 5 To 21 If ws.Cells(2, i).Value <> "" Then Me.cmbOptions.AddItem ws.Cells(2, i).Value End If Next i ElseIf Me.optStandard.Value Then ' Populate ComboBox with standards (Columns V to AC) For i = 22 To 29 If ws.Cells(2, i).Value <> "" Then Me.cmbOptions.AddItem ws.Cells(2, i).Value End If Next i End If ' Populate unique domains (Column A) For i = 4 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row If ws.Cells(i, 1).Value <> "" Then If Not uniqueDomains.exists(ws.Cells(i, 1).Value) Then uniqueDomains.Add ws.Cells(i, 1).Value, True Me.lstDomain.AddItem ws.Cells(i, 1).Value End If End If Next i ' Populate unique risk priorities (Column AR) For i = 4 To ws.Cells(ws.Rows.Count, 44).End(xlUp).Row If ws.Cells(i, 44).Value <> "" Then If Not uniqueRiskPriorities.exists(ws.Cells(i, 44).Value) Then uniqueRiskPriorities.Add ws.Cells(i, 44).Value, True Me.lstRiskPriority.AddItem ws.Cells(i, 44).Value End If End If Next i End Sub Private Sub btnGenerateReport_Click() Dim wsMain As Worksheet, wsReport As Worksheet, wbNew As Workbook Dim selectedOption As String, selectedDomains As Object, selectedRiskPriorities As Object Dim startCol As Long, endCol As Long, reportRow As Long Dim i As Long, lastRow As Long, optionFound As Boolean Set wsMain = ThisWorkbook.Sheets("Integrated Control sheet") Set wsReport = ThisWorkbook.Sheets("Report Sheet") Set selectedDomains = CreateObject("Scripting.Dictionary") Set selectedRiskPriorities = CreateObject("Scripting.Dictionary") wsReport.Cells.Clear ' Clear previous report data ' Get selected ComboBox value selectedOption = Me.cmbOptions.Value If selectedOption = "" Then MsgBox "Please select an option from the dropdown.", vbExclamation Exit Sub End If ' Get selected domains 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 ' Get selected risk priorities 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 ' Find start and end columns for selected option If Me.optCountry.Value Then Select Case selectedOption Case "UAE" startCol = 5 endCol = 8 Case "Hong Kong" startCol = 9 endCol = 9 Case "India" startCol = 10 endCol = 11 Case "Kuwait" startCol = 12 endCol = 12 Case "Qatar" startCol = 13 endCol = 13 Case "Oman" startCol = 14 endCol = 15 Case "Bahrain" startCol = 16 endCol = 17 Case "Pakistan" startCol = 18 endCol = 19 Case "USA" startCol = 20 endCol = 21 Case Else MsgBox "Selected country is not available.", vbExclamation Exit Sub End Select ElseIf Me.optStandard.Value Then For i = 22 To 29 If wsMain.Cells(2, i).Value = selectedOption Then startCol = i endCol = i Exit For End If Next i End If ' Copy headers wsMain.Range("A1:D3").Copy wsReport.Range("A1") wsMain.Range(wsMain.Cells(1, startCol), wsMain.Cells(3, endCol)).Copy wsReport.Cells(1, 5) wsMain.Range(wsMain.Cells(1, 30), wsMain.Cells(3, 54)).Copy wsReport.Cells(1, 5 + (endCol - startCol + 1)) ' Copy data rows based on filters lastRow = wsMain.Cells(wsMain.Rows.Count, 1).End(xlUp).Row reportRow = 4 For i = 4 To lastRow 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 wsMain.Range(wsMain.Cells(i, 1), wsMain.Cells(i, 4)).Copy wsReport.Cells(reportRow, 1) wsMain.Range(wsMain.Cells(i, startCol), wsMain.Cells(i, endCol)).Copy wsReport.Cells(reportRow, 5) wsMain.Range(wsMain.Cells(i, 30), wsMain.Cells(i, 54)).Copy wsReport.Cells(reportRow, 5 + (endCol - startCol + 1)) reportRow = reportRow + 1 End If Next i ' Remove rows with all blank country columns Call RemoveBlankCountryRows(wsReport, startCol, endCol) ' Save the report Set wbNew = Application.Workbooks.Add wsReport.Copy Before:=wbNew.Sheets(1) wbNew.Sheets(1).Name = "Generated Report" Dim newFileName As String 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 Unload Me End Sub Private Sub RemoveBlankCountryRows(wsReport As Worksheet, startCol As Long, endCol As Long) Dim lastRow As Long, i As Long, j As Long lastRow = wsReport.Cells(wsReport.Rows.Count, 1).End(xlUp).Row ' Loop from the bottom to the top to avoid shifting rows during deletion For i = lastRow To 4 Step -1 Dim isRowEmpty As Boolean isRowEmpty = True ' Assume the row is empty initially ' Check all cells in the country-specific range (from startCol to endCol) For j = startCol To endCol If wsReport.Cells(i, j).Value <> "" Then isRowEmpty = False ' If any cell in the range is non-empty, set to False Exit For ' Exit the loop as we only need to find one non-empty cell End If Next j ' If the row is empty (all country columns are blank), delete the row If isRowEmpty Then wsReport.Rows(i).Delete End If Next i End Sub
Leave a Comment