Untitled

 avatar
unknown
plain_text
16 days ago
3.9 kB
2
Indexable
Private Sub btnGenerateReport_Click()
    Dim wsMain As Worksheet
    Dim wsReport As Worksheet
    Dim lastRow As Long
    Dim selectedOption As String
    Dim startCol As Long, endCol As Long
    Dim reportRow As Long

    Set wsMain = ThisWorkbook.Sheets("Integrated Control sheet")
    Set wsReport = ThisWorkbook.Sheets("Report Sheet")

    ' Clear previous data in the report sheet
    wsReport.Cells.Clear

    ' Get the selected option from ComboBox
    selectedOption = Me.cmbOptions.Value

    If selectedOption = "" Then
        MsgBox "Please select an option from the dropdown.", vbExclamation
        Exit Sub
    End If

    ' Get column range for selected option
    If Me.optCountry.Value Then
        SetHeaderRange wsMain, selectedOption, startCol, endCol, 5, 21 ' Columns E to U
    ElseIf Me.optStandard.Value Then
        SetHeaderRange wsMain, selectedOption, startCol, endCol, 22, 29 ' Columns V to AC
    End If

    If startCol = 0 Then
        MsgBox "Selected option not found in headers.", vbExclamation
        Exit Sub
    End If

    ' Copy headers and data to Report Sheet
    CopyHeadersAndData wsMain, wsReport, startCol, endCol

    ' Filter rows to remove blanks within the selected column range
    FilterAndRemoveBlankRows wsReport, startCol, endCol

    MsgBox "Report generated successfully!", vbInformation
End Sub

Private Sub SetHeaderRange(ws As Worksheet, optionValue As String, ByRef startCol As Long, ByRef endCol As Long, colStart As Long, colEnd As Long)
    Dim i As Long
    startCol = 0
    endCol = 0

    ' Identify start and end column for the selected option
    For i = colStart To colEnd
        If ws.Cells(2, i).Value = optionValue Then
            startCol = i
            endCol = ws.Cells(2, i).MergeArea.Columns.Count + startCol - 1
            Exit For
        End If
    Next i
End Sub

Private Sub CopyHeadersAndData(wsMain As Worksheet, wsReport As Worksheet, startCol As Long, endCol As Long)
    Dim lastRow As Long
    Dim reportRow As Long
    Dim i As Long

    ' Copy general headers (A:D)
    wsMain.Range("A1:D3").Copy Destination:=wsReport.Range("A1")

    ' Copy selected option 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))

    ' Copy rows based on filters
    lastRow = wsMain.Cells(wsMain.Rows.Count, 1).End(xlUp).Row
    reportRow = 4 ' Start copying data from row 4

    For i = 4 To lastRow
        ' Always 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 column range
        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
    Next i
End Sub

Private Sub FilterAndRemoveBlankRows(ws As Worksheet, startCol As Long, endCol As Long)
    Dim lastRow As Long
    Dim i As Long
    Dim isRowEmpty As Boolean
    Dim j As Long

    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' Loop through rows from bottom to top
    For i = lastRow To 4 Step -1
        isRowEmpty = True

        ' Check if all cells in the selected column range are blank
        For j = startCol To endCol
            If ws.Cells(i, j).Value <> "" Then
                isRowEmpty = False
                Exit For
            End If
        Next j

        ' Delete row if empty
        If isRowEmpty Then
            ws.Rows(i).Delete
        End If
    Next i
End Sub
Leave a Comment