Hola carlosjrey.
Private Sub ExportarXls(Byval Rs as Recodset)
On Error GoTo Err_XLS
Dim objApp As Object
Dim objWb As Object
Dim objSh As Object
Dim lngR As Long, lngC As Long
If Rs Is Nothing Then goto Exit_Xls
Set objApp = CreateObject("Excel.Application")
Set objWb = objApp.WorkBooks.Add
Set objSh = objWb.ActiveSheet
For lngC = 0 To Rs.Fields.Count - 1
ObjSh.Cells(1, lngC + 1) = Rs.Fields(lngC).Name
Next LngC
If Rs.RecordCount > 0 Then Rs.MoveFirst
lngR = 1
Do Until Rs.EOF
lngR = lngR + 1
For lngC = 0 To Rs.Fields.Count - 1
objSh.Cells(lngR, lngC + 1) = Rs.Fields(lngC).Value
Next lngC
Rs.MoveNext
Loop
objWb.SaveCopyAs "c:\ruta\nombre.xls"
objWb.Saved = True
Exit_XLS:
On Local Error Resume Next
Rs.Close
Set Rs = Nothing
objApp.Close
objApp.Quit
Set objSh = Nothing
Set objWb = Nothing
Set objApp = Nothing
Exit Sub
Err_XLS:
MsgBox "(" & Err.Number & ") " & Err.Description, vbCritical, "Xls"
Resume Exit_XLS
End Sub
El código es prácticamente el mismo que le di a rechy unos cuantos post atrás... pero la comodidad es la comodidad...
Ale, abur.
