How can I Export a filtered listbox to Excel (1 Viewer)

[mtn]

Dear all,

I have a BIG challange and I confident someone here can assist me. I have a list box with whose row source is a query (QryEmployees) bout to the table (tblEmployees). On my form I have a search box that filter the information as you type a serach item. What I want is to be able to export what I have on the list box to an excel sheet rather than exporting the whole table (tblEmployees) or the whole query (QryEmployees).

I am presently using the following code to export either a table or query to excel with out any challange. I got it from here and it works perfectly. What I want now is how to modify this code to export only what I have displayed on my list box.

Here is the code:

Sub ExportToXL2()

Dim rs As ADODB.Recordset
Dim fld As ADODB.Field
Dim oAppXL As Object, oWbXL As Object, oWsXL As Object
Dim i As Long, FileName As String
Dim bIsStartedXL As Boolean
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
Dim Outputfiledate As String

Set rs = New ADODB.Recordset

'
'Set Excel objects
On Error Resume Next
Set oAppXL = GetObject(, "Excel.Application")
If CBool(err.Number) Then
Set oAppXL = CreateObject("Excel.Application")
bIsStartedXL = True
err.Clear
End If
On Error GoTo 0

Set oWbXL = oAppXL.Workbooks.Add

'Delete all sheets but first one...
oAppXL.DisplayAlerts = False
For i = oWbXL.Sheets.Count To 2 Step -1
oWbXL.Sheets(i).Delete
Next i
oAppXL.DisplayAlerts = True
Set oWsXL = oWbXL.Sheets(1)
'
'get the name and rename the sheet, save the workbook under this name
On Error Resume Next
'FileName = Format$(Now(), "mm-dd-yy")

Outputfiledate = Format$(Now(), "mm-dd-yy")
FileName = "Fleet Staff List" & Outputfiledate & ""
oWsXL.Name = FileName

'oWbXL.SaveAs CurrentProject.path & "\" & FileName & ".xls"
oWbXL.SaveAs "c:\documents and settings\all users\desktop\" & FileName & ".xls"
err.Clear
On Error GoTo 0

'open a recorset
'rs.Open "tblEmployees", CurrentProject.Connection, 3, 2, 2

If rs.RecordCount < 1 Then
MsgBox "The report you are trying to produce does not contain any data!" & vbCr & vbCr & _
"Please check that there is data for this report.", vbCritical, " - No Data"
Else
If rs.RecordCount > 0 Then

With oWsXL
'fill the headers in the sheet
For Each fld In rs.Fields
If IsEmpty(.[A1]) Then
.[A1] = fld.Name
Else
.[iv1].End(-4159).Item(, 2).Value = fld.Name
End If
Next fld
'dump the recordset onto the sheet
.[A2].CopyFromRecordset rs

'With .Range("A1:CW1")
With .Range("A1:AM1")
.Interior.ColorIndex = 11
.Font.ColorIndex = 2
.AutoFilter
'.EntireColumn.ColumnWidth = 27
End With

'format column N and O to be currency if need be
'With .Range("N:O")
'.NumberFormat = "[$$-409]#,##0.00"
'End With

'format column P to be percentage if need be
'With .Range("P")
'.NumberFormat = "0%"
'End With

' selects all of the cells
'oAppXL.ActiveSheet.Cells.Select

' does the "autofit" for all columns
oAppXL.ActiveSheet.Cells.EntireColumn.AutoFit

.Columns("W:Y").WrapText = True
.Parent.Save
End With

With oAppXL.Selection.Font
.Name = "Tahoma"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With

oAppXL.Selection.Font.Bold = True
With oAppXL.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
'

'CLEANUP
'1. Close the recordsets, release variables
If rs.State And adStateOpen Then rs.Close: Set rs = Nothing

'2. Optionally, close the workbook and release the object pointers
Set oWsXL = Nothing
If MsgBox("Do you want to close the employee records just you created?", vbQuestion + vbQuestion + vbYesNo) = vbYes Then
oWbXL.Close
If bIsStartedXL Then oAppXL.Quit
End If
If bIsStartedXL Then oAppXL.Visible = True
Set oWbXL = Nothing: Set oAppXL = Nothing

End If
End If
End Sub

 

[DCrake]

I have a demo that does everything you want up to the point of pasting into Excel. Take a look and see if this helps. It it the first on the list.Sample databases - Copy to clipboard

 

[mtn]

Thanks for your help Dave.
I have observed that your listbox MultiSelect property is set to Simple which enables the select all button to be able to select all the rows on your listbox. This is not the case with mine as it's set to none.

How can i modify your code to either at run time or somehow change this property to simple when I clik the button and change it back to none once I click the copy button?

One thing to note also is that my listbox rowsource changes depending on the button I click so at various times I will have different rowsource.

 

[DCrake]

The basic concept is to work on a listbox. lets assume you have all items selected. What is does is two loops

For r = 0 to List Count - Each item in list
   For C = 0 to Column count - each column in listbox
     Here you concat all the columns together with a vbtab delimiter
     Then you issue a line feed after last column
   Next
   Move to next item in listbox
Next

So you end up with a two dimensional array of items from the list box. This is then used to populate Excel.

 

[mtn]

Here is what I have done:

Private Sub cmdCopyToExcel_Click()
On Error GoTo ErrorHandler
Dim sData As String
Dim X As Integer

'Select all
Set lst = Me![lstContacts]
lngRows = lst.ListCount - 1
For lngIndex = 0 To lngRows
lst.Selected(lngIndex) = True
Next lngIndex

'Copy all
sData = sData & "Drivers Name" & vbTab & "Work Phone" & vbTab & "Phone Number" & vbTab & "Heading 4" & vbCrLf

'x would be set to row 1 if using column heading in list
For X = 0 To Me.lstContacts.ListCount
If Me.lstContacts.Selected(X) = True Then
sData = sData & Me.lstContacts.Column(0, X) & vbTab & Me.lstContacts.Column(1, X) & vbTab & Me.lstContacts.Column(2, X) & vbTab & Me.lstContacts.Column(3, X) & vbTab & Me.lstContacts.Column(4, X) & vbTab & vbCrLf
End If
Next

'Copy the data to the clipboard
ClipBoard_SetData (sData)

'Deselect all
Set lst = Me![lstContacts]
lngRows = lst.ListCount - 1
For lngIndex = 0 To lngRows
lst.Selected(lngIndex) = False
Next lngIndex

'Let user know that the procedure has been completed
MsgBox "Data copied to clipboard", vbInformation + vbOKOnly, "Data Copied"

ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & _
Err.Description
Resume ErrorHandlerExit
End Sub

So the idea is for me to select all the rows with the listbox muliti select proerty already changed to Extended. After the selection, the information is copied and immediately deselected. The user can now paste the information in an excel sheet. This works fine but then it disables my after update event of the list box. This is because the muli select property has been changed form None to Extended.

What I am thing is to have another hidden listbox that will have the same rowsourse as my main listbox. While the latter can attend to my after update, the hidden can serve as a point of copying the information from. I don't know if that is a good design method.