Untitled
user_1123194
plain_text
9 months ago
7.0 kB
6
Indexable
' This is triggered when the UserForm is initialized
Private Sub UserForm_Initialize()
Call PopulateOptions
End Sub
' These handle Country/Standard option selection
Private Sub optCountry_Click()
Call PopulateOptions
End Sub
Private Sub optStandard_Click()
Call PopulateOptions
End Sub
' Populate the ComboBox and filters based on selection
Private Sub PopulateOptions()
Dim ws As Worksheet
Dim i As Long
Dim uniqueDomains As Object
Dim uniqueRiskPriorities As Object
Dim cellValue As String
' Set worksheet and dictionaries
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 ComboBox for countries or standards
If Me.optCountry.Value Then
' Populate 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 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 Domain list (Column A)
For i = 4 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
cellValue = ws.Cells(i, 1).Value
If cellValue <> "" And Not uniqueDomains.exists(cellValue) Then
uniqueDomains.Add cellValue, True
Me.lstDomain.AddItem cellValue
End If
Next i
' Populate Risk Priority list (Column AR)
For i = 4 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
cellValue = ws.Cells(i, 44).Value ' Column AR
If cellValue <> "" And Not uniqueRiskPriorities.exists(cellValue) Then
uniqueRiskPriorities.Add cellValue, True
Me.lstRiskPriority.AddItem cellValue
End If
Next i
End Sub
' Generate the report based on the selected filters
Private Sub btnGenerateReport_Click()
Dim wsMain As Worksheet, wsReport As Worksheet
Dim wbNew As Workbook
Dim selectedOption As String, newFileName As String
Dim selectedDomains As Object, selectedRiskPriorities As Object
Dim startCol As Long, endCol As Long
Dim lastRow As Long, reportRow As Long
Dim i As Long, j As Long
Dim headerRange As Range, optionFound As Boolean
Dim rowHasData As Boolean
' Initialize variables
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 the Report Sheet
' Get selected option
selectedOption = Me.cmbOptions.Value
If selectedOption = "" Then
MsgBox "Please select an option from the dropdown.", vbExclamation
Exit Sub
End If
' Gather selected domains and risk priorities
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
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
' Determine the column range for the selected option
If Me.optCountry.Value Then
' Handle country selection
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 selection
For j = 22 To 29 ' Columns V to AC
If wsMain.Cells(2, j).Value = selectedOption Then
startCol = j
endCol = j
optionFound = True
Exit For
End If
Next j
If Not optionFound Then
MsgBox "Standard not found!", vbExclamation
Exit Sub
End If
End If
' Copy headers
wsMain.Range("A1:D3").Copy Destination:=wsReport.Range("A1")
wsMain.Range(wsMain.Cells(1, startCol), wsMain.Cells(3, endCol)).Copy _
Destination:=wsReport.Cells(1, 5)
wsMain.Range(wsMain.Cells(1, 30), wsMain.Cells(3, 54)).Copy _
Destination:=wsReport.Cells(1, 5 + (endCol - startCol + 1))
' Filter and copy rows
lastRow = wsMain.Cells(wsMain.Rows.Count, 1).End(xlUp).Row
reportRow = 4 ' Start writing data from row 4
For i = 4 To lastRow
rowHasData = False
' For countries: Check if at least one cell in the range has data
If Me.optCountry.Value Then
For j = startCol To endCol
If Trim(wsMain.Cells(i, j).Value) <> "" Then
rowHasData = True
Exit For
End If
Next j
End If
' For standards: Check if the selected cell is not empty
If Me.optStandard.Value Then
If Trim(wsMain.Cells(i, startCol).Value) <> "" Then
rowHasData = True
End If
End If
' Check domain and risk priority filters
If rowHasData And (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 row data
wsMain.Range(wsMain.Cells(i, 1), wsMain.Cells(i, 4)).Copy _
Destination:=wsReport.Cells(reportRow, 1)
wsMain.Range(wsMain.Cells(i, startCol), wsMain.Cells(i, endCol)).Copy _
Destination:=wsReport.Cells(reportRow, 5)
wsMain.Range(wsMain.Cells(i, 30), wsMain.Cells(i, 54)).Copy _
Destination:=wsReport.Cells(reportRow, 5 + (endCol - startCol + 1))
reportRow = reportRow + 1
End If
Next i
' Create and save the report
Set wbNew = Application.Workbooks.Add
wsReport.Copy Before:=wbNew.Sheets(1)
wbNew.Sheets(1).Name = "Generated Report"
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
Editor is loading...
Leave a Comment