Exporting Listbox Row Source to Excel

[mrliam69]

Hi can someone help

I have some listboxes (from the toolbox) that users want to export to an excel spreadsheet akin to how Crystal reports does it whereby it opens in a temp excel sheet then you have to save it....

 

[hermanlaksko]

First you must make a ref. to Excel via Tools/Refrences.

Use this to transfer data to excel:

Function Test2Xl()
Dim Re As DAO.Recordset, MyXL As Object, FrCol, ToCol, HeadRow
OpenExcell ""
Set MyXL = GetObject(, "Excel.Application")
FrCol = "A"
ToCol = ":I"
HeadRow = 2

Set Re = CurrentDb.OpenRecordset("Select * From YourTbl")
If Re.RecordCount > 0 Then
Do While Not Re.EOF
MyXL.ActiveWorkbook.ActiveSheet.Columns("E:H").ColumnWidth = 6
MyXL.ActiveWorkbook.ActiveSheet.Cells(HeadRow, 1).Value = "'" & Re!YrFld
MyXL.ActiveWorkbook.ActiveSheet.Range(FrCol & HeadRow & ToCol & HeadRow).Select
MyXL.ActiveWorkbook.ActiveSheet.Range(FrCol & HeadRow & ToCol & HeadRow).HorizontalAlignment = xlCenter
MyXL.ActiveWorkbook.ActiveSheet.Range(FrCol & HeadRow & ToCol & HeadRow).VerticalAlignment = xlBottom
MyXL.ActiveWorkbook.ActiveSheet.Range(FrCol & HeadRow & ToCol & HeadRow).ShrinkToFit = False
MyXL.ActiveWorkbook.ActiveSheet.Range(FrCol & HeadRow & ToCol & HeadRow).WrapText = True
MyXL.ActiveWorkbook.ActiveSheet.Range(FrCol & HeadRow & ToCol & HeadRow).ReadingOrder = xlContext
MyXL.ActiveWorkbook.ActiveSheet.Range(FrCol & HeadRow & ToCol & HeadRow).MergeCells = True
MyXL.ActiveWorkbook.ActiveSheet.Range(FrCol & HeadRow & ToCol & HeadRow).Font.Bold = True
MyXL.ActiveWorkbook.ActiveSheet.Range(FrCol & HeadRow & ToCol & HeadRow).Font.Size = 14
HeadRow = HeadRow + 1
Re.MoveNext
Loop
End If
End Function

I have incl. some extra features for you 2 play with if you like. Also you will need the code below to get excel up and running ;-)

Function OpenExcell(ExSheet)'Start Xl
On Error GoTo Fejl
Dim MyXL As Object
IsRunning
Set MyXL = GetObject(, "Excel.Application")
If Not IsBlank(ExArk) Then Workbooks.Open ExArk
If MyXL.Workbooks.Count = 0 Then MyXL.Workbooks.Add
MyXL.Application.Visible = True
MyXL.Worksheets(1).Visible = xlSheetVisible

FejlExit:
Set MyXL = Nothing
Exit Function
Fejl:
If Err = 429 Then
Set MyXL = CreateObject("Excel.Application")
MyXL.Workbooks.Add
Resume Next
Else
MsgBox Err.Number & " - " & Err.Description, , "YrApp"
End If
Resume FejlExit
End Function

Public Function IsRunning() As Boolean 'Is it running - really?
Dim obj As Object
On Error GoTo IsRunningEH
Set obj = GetObject(, "Excel.Application") 'try to set it
IsRunning = True 'will fail if not running
If IsRunning Then
obj.DisplayAlerts = False
obj.Quit
obj.DisplayAlerts = True
End If
IsRunningEH:
Exit Function
End Function
'Chks for IsNull, IsEmpty, "", etc in one go
Function IsBlank(V As Variant) As Boolean
On Error Resume Next
V = "" & V
If Len(V) = 0 Then IsBlank = True
End Function

Herman
Say no to macros