' 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 |