Untitled
unknown
plain_text
9 months ago
4.9 kB
4
Indexable
Private Sub btnGenerateReport_Click()
Dim wsMain As Worksheet
Dim wsReport As Worksheet
Dim wbNew As Workbook
Dim lastRow As Long
Dim selectedOption As String
Dim selectedDomains As Object
Dim selectedRiskPriorities As Object
Dim i As Long, j As Long
Dim reportRow As Long
Dim startCol As Long, endCol As Long
Dim headerRange As Range
Dim optionFound As Boolean
Dim newFileName As String
Set wsMain = ThisWorkbook.Sheets("Integrated Control sheet")
Set wsReport = ThisWorkbook.Sheets("Report Sheet")
' Create dictionaries for selected filters
Set selectedDomains = CreateObject("Scripting.Dictionary")
Set selectedRiskPriorities = CreateObject("Scripting.Dictionary")
wsReport.Cells.Clear ' Clear the Report Sheet
' Get selected combo box value (Country or Standard)
selectedOption = Me.cmbOptions.Value
If selectedOption = "" Then
MsgBox "Please select an option from the dropdown.", vbExclamation
Exit Sub
End If
' Add selected domains to the dictionary
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
' Add selected risk priorities to the dictionary
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
optionFound = False
If Me.optCountry.Value Then
' Handle Country-specific logic
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-specific logic
For j = 22 To 29 ' Columns V to AC
If wsMain.Cells(2, j).Value = selectedOption Or wsMain.Cells(3, j).Value = selectedOption Then
startCol = j
endCol = j
optionFound = True
Exit For
End If
Next j
If Not optionFound Then
MsgBox "Standard not found in the headers!", vbExclamation
Exit Sub
End If
End If
' Copy general headers (A:D)
wsMain.Range("A1:D3").Copy Destination:=wsReport.Range("A1")
' Copy selected Country or Standard-specific headers
wsMain.Range(wsMain.Cells(1, startCol), wsMain.Cells(3, endCol)).Copy _
Destination:=wsReport.Cells(1, 5)
' Copy additional headers (AD:BB)
wsMain.Range(wsMain.Cells(1, 30), wsMain.Cells(3, 54)).Copy _
Destination:=wsReport.Cells(1, 5 + (endCol - startCol + 1))
' Generate the report based on selected filters
lastRow = wsMain.Cells(wsMain.Rows.Count, 1).End(xlUp).Row
reportRow = 4 ' Start writing data from row 4 in the Report Sheet
For i = 4 To lastRow
' Check if the row matches the selected filters
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
' Copy general data (A:D)
wsMain.Range(wsMain.Cells(i, 1), wsMain.Cells(i, 4)).Copy _
Destination:=wsReport.Cells(reportRow, 1)
' Copy data for selected Country or Standard
wsMain.Range(wsMain.Cells(i, startCol), wsMain.Cells(i, endCol)).Copy _
Destination:=wsReport.Cells(reportRow, 5)
' Copy additional data (AD:BB)
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
' Call the macro from Module 2 to filter rows with blank columns (E, F, etc.)
Call FilterAndRemoveBlankRows
' Create a new workbook and copy the report
Set wbNew = Application.Workbooks.Add
wsReport.Copy Before:=wbNew.Sheets(1)
' Name the new worksheet appropriately
wbNew.Sheets(1).Name = "Generated Report"
' Prompt user for file name
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 the new workbook if not saved
Unload Me
End Sub
Editor is loading...
Leave a Comment