Export to Excel

' Use one of the following to export what you need
Call ExportToExcel(ReportControl) ' Exports the ReportControl 
Call ExportToExcel(ReportControl, true) ' Exports the ReportControl, but only the selected rows
Call ExportToExcel(ReportControl, , "10,11,12") ' Exports the ReportControl, but ignores Columns 10 to 12
Call ExportToExcel(ReportControl, true, "10,11,12") ' Exports the ReportControl, but only the selected rows and ignores Columns 10 to 12

' PS. The ignore Columns can be anything you want like 1,4,9,20 as long as it corresponds to a column in the ReportControl. You also must use the Microsoft Excel Reference within your Project.

' The reusable ExportToExcel procedure
Public Sub ExportToExcel(rpc As ReportControl, Optional ExportOnlySelected As Boolean = False, Optional IgnoreCols As String = vbNullString)
    Dim Record As ReportRecord
    Dim xlsApp As Excel.Application
    Dim xlsWSheet As Excel.Worksheet
    Dim i As Long, j As Long, x As Long, z As Long
    
    ' Get or Create Excel Object
    On Error Resume Next
    Set xlsApp = GetObject(, "Excel.Application")

    If Err.Number <> 0 Then
        Set xlsApp = New Excel.Application
        Err.Clear
    End If

    ' Create the WorkSheet
    Set xlsWSheet = xlsApp.Workbooks.Add.ActiveSheet
    
    With xlsWSheet

        ' Export Data from the ReportControl
        If ExportOnlySelected Then
            x = 1

            For i = 0 To rpc.Records.Count - 1
                If rpc.Rows(i).Selected Then
                    x = x + 1
                    z = 1
                    
                    Set Record = rpc.Records.Record(i)
                    For j = 1 To rpc.Columns.Count
                        If Not InstrEx(IgnoreCols, CStr(j - 1), ",") Then
                            .Cells(x, z) = Record.Item(j - 1).Value
                            .Cells(x, z) = IIf(Len(Record.Item(j - 1).Value) = 6, "01/" & Format$(CStr(Record.Item(j - 1).Value), "mm/yyyy"), CStr(Record.Item(j - 1).Value))
                        
                            If Trim$(CStr(Record.Item(j - 1).Value)) = vbNullString And Record.Item(j - 1).Icon > -1 Then
                                .Cells(x, z) = CStr(Record.Item(j - 1).Tag)
                            End If
                            
                            ' Format the Cell, if the value is a number then format as such otherwise format as text
                            Select Case IsNumeric(Record.Item(j - 1).Value)
                                Case False
                                    Select Case IsDate(Record.Item(j - 1).Value)
                                        Case False
                                            .Cells(x, z).NumberFormat = "@"
                                        Case True
                                            If Len(Record.Item(j - 1).Value) = 6 Then
                                                .Cells(i + 2, z).NumberFormat = "@"
                                                .Cells(i + 2, z) = CStr(Record.Item(j - 1).Value)
                                            Else
                                                .Cells(i + 2, z).NumberFormat = "dd/mm/yyyy"
                                                .Cells(i + 2, z) = Format$(.Cells(i + 2, z), "dd/mm/yyyy")
                                            End If
                                    End Select
                                Case True
                                    .Cells(x, z).NumberFormat = "#,##0"
                            End Select
                        End If
                        
                        z = z + 1
                    Next
                End If
            Next
        Else
            For i = 0 To rpc.Records.Count - 1
                z = 1
                Set Record = rpc.Records.Record(i)
                For j = 1 To rpc.Columns.Count
                    If Not InstrEx(IgnoreCols, CStr(j - 1), ",") Then
                        .Cells(i + 2, z) = CStr(Record.Item(j - 1).Value)
                        '.Cells(i + 2, z) = IIf(Len(Record.Item(j - 1).Value) = 6, "01/" & Format$(CStr(Record.Item(j - 1).Value), "mm/yyyy"), CStr(Record.Item(j - 1).Value))
                        
                        If Trim$(CStr(Record.Item(j - 1).Value)) = vbNullString And Record.Item(j - 1).Icon > -1 Then
                            .Cells(i + 2, z) = CStr(Record.Item(j - 1).Tag)
                        End If
    
                        ' Format the Cell, if the value is a number then format as such otherwise format as text
                        Select Case IsNumeric(Record.Item(j - 1).Value)
                            Case False
                                Select Case IsDate(Record.Item(j - 1).Value)
                                    Case False
                                        .Cells(i + 2, z).NumberFormat = "@"
                                    Case True
                                        If Len(Record.Item(j - 1).Value) = 6 Then
                                            .Cells(i + 2, z).NumberFormat = "@"
                                            .Cells(i + 2, z) = CStr(Record.Item(j - 1).Value)
                                        Else
                                            .Cells(i + 2, z).NumberFormat = "dd/mm/yyyy"
                                            .Cells(i + 2, z) = Format$(.Cells(i + 2, z), "dd/mm/yyyy")
                                        End If
                                End Select
                            Case True
                                .Cells(i + 2, z).NumberFormat = "#,##0"
                        End Select
                        
                        z = z + 1
                    End If
                Next
            Next
        End If

        ' Format the Columns
        z = 0
        For i = 0 To rpc.Columns.Count - 1
            If Not InstrEx(IgnoreCols, CStr(i), ",") Then
                ' Export ColumnHeaders & set as bold
                .Cells(1, z + 1) = rpc.Columns(i).Caption
                .Cells(1, z + 1).Font.Bold = True
            
                ' Autofit column headers
                .Columns(z + 1).AutoFit
                
                ' Format the Column Alignments
                Select Case rpc.Columns.Column(i).Alignment
                    Case xtpAlignmentCenter
                        .Columns(z + 1).HorizontalAlignment = xlCenter
                    Case xtpAlignmentRight
                        .Columns(z + 1).HorizontalAlignment = xlRight
                    Case Else
                        .Columns(z + 1).HorizontalAlignment = xlLeft
                End Select
                
                z = z + 1
            End If
            
        Next
    
        ' Move to first cell to unselect
        .Range("A1").Select
    End With
   
    ' Show the Excel Window
    With xlsApp
        .ActiveWindow.SplitRow = 1
        .Windows(1).FreezePanes = True
        .Visible = True
    End With
    
    Set xlsApp = Nothing
    Set xlsWSheet = Nothing
End Sub