Untitled
user_1123194
plain_text
a year ago
6.0 kB
9
Indexable
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
Dim uniqueRiskPriorities As Object
Dim cellValue As String
' Initialize variables
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 Country or Standard
If Me.optCountry.Value Then
For i = 5 To 21 ' Columns E to U
If ws.Cells(2, i).Value <> "" Then
Me.cmbOptions.AddItem ws.Cells(2, i).Value
End If
Next i
ElseIf Me.optStandard.Value Then
For i = 22 To 29 ' Columns V to AC
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
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 unique Risk Priorities (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
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
Dim headerRange As Range, optionFound 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 combo box value
selectedOption = Me.cmbOptions.Value
If selectedOption = "" Then
MsgBox "Please select an option from the dropdown.", vbExclamation
Exit Sub
End If
' Add selected domains and risk priorities to dictionaries
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
' Handle Country selection
If Me.optCountry.Value Then
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
End If
' Handle Standard selection
If Me.optStandard.Value Then
For i = 22 To 29 ' Columns V to AC
If wsMain.Cells(2, i).Value = selectedOption Then
startCol = i
endCol = i
optionFound = True
Exit For
End If
Next i
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
If Me.optCountry.Value Then
' For Country: Delete rows with blanks in selected columns
If Application.WorksheetFunction.CountBlank(wsMain.Range(wsMain.Cells(i, startCol), wsMain.Cells(i, endCol))) = 0 Then
wsMain.Rows(i).Copy Destination:=wsReport.Rows(reportRow)
reportRow = reportRow + 1
End If
ElseIf Me.optStandard.Value Then
' For Standard: Keep rows with data in selected column
If wsMain.Cells(i, startCol).Value <> "" Then
wsMain.Rows(i).Copy Destination:=wsReport.Rows(reportRow)
reportRow = reportRow + 1
End If
End If
Next i
' Create and save a new workbook
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 ' Close if not saved
Unload Me
End Sub
Editor is loading...
Leave a Comment