Untitled
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 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 (both country-specific columns are blank), delete the row If isRowEmpty Then wsReport.Rows(i).Delete 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 Dim headerRange As Range 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 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 ' Delete rows where country-specific columns are blank first RemoveBlankCountryRows wsReport, startCol, endCol ' 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 ' 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
Leave a Comment