Untitled

 avatar
user_1123194
plain_text
15 days ago
6.0 kB
1
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
Leave a Comment