Untitled

 avatar
user_1123194
plain_text
24 days ago
7.0 kB
4
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
Leave a Comment