VB E EXCEL

USUARIO.EXCLUIDOS 11/01/2005 08:50:47
#59929
Olá, como faço para enviar dados para o excel e em seguida abrir esse arquivo?

Valew...
USUARIO.EXCLUIDOS 11/01/2005 08:51:57
#59930 Resposta escolhida
assim ve se vc entende:

Sub ExportaExcel(ByVal sql As String, Optional titulo_Tabla As String = "")
Dim tb As New Recordset
Dim libro As New Excel.Application

tb.Open sql, cn, adOpenKeyset
With libro
libro.Visible = True
libro.Workbooks.Add
With .Range("C1")
.Value = titulo_Tabla
.Font.Bold = True
.Font.Name = "Times New Roman"
.Font.Size = 12
End With
With .Range("A3")
.Value = "Fecha : " + CStr(Date)
.Font.Bold = True
.Font.Name = "Times New Roman"
.Font.Size = 12
End With
With .Range("A4")
.Value = "Hora : " + CStr(Time)
.Font.Bold = True
.Font.Name = "Times New Roman"
.Font.Size = 12
End With
Dim b As Integer, Fil As Integer
For b = 0 To tb.Fields.Count - 1
.Cells(6, b + 1).Value = tb.Fields(b).Name
Next
Fil = 0
'Exportación de la data
tb.MoveFirst
Do While Not tb.EOF
For b = 0 To tb.Fields.Count - 1
.Cells(7 + Fil, b + 1).Value = tb.Fields(b)
Next
Fil = Fil + 1
tb.MoveNext
Loop

End With
libro.Range("A6:" + Chr(96 + b) + CStr(Fil + 7)).AutoFormat xlRangeAutoFormatClassic3
End Sub
USUARIO.EXCLUIDOS 11/01/2005 08:52:50
#59932
Lembre-se que tem de fazer referencia... antes de usar
USUARIO.EXCLUIDOS 11/01/2005 08:53:25
#59933
Coloque isto em um módulo:

Public Sub Recordset2Excel(rstsource As ADODB.Recordset)
Dim xlsApp As Excel.Application
Dim xlsWBook As Excel.Workbook
Dim xlsWSheet As Excel.Worksheet
Dim i, j As Integer

' 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 WorkSheet
Set xlsWBook = xlsApp.Workbooks.Add
Set xlsWSheet = xlsWBook.ActiveSheet

' Export ColumnHeaders


For j = 0 To rstsource.Fields.Count
xlsWSheet.Cells(2, j + 1) = rstsource.Fields(j).name
Next j

' Export Data
rstsource.MoveFirst


For i = 1 To rstsource.RecordCount


For j = 0 To rstsource.Fields.Count
xlsWSheet.Cells(i + 2, j + 1) = rstsource.Fields(j).Value
Next j
rstsource.MoveNext
Next i
rstsource.MoveFirst
' Autofit column headers


For i = 1 To rstsource.Fields.Count
xlsWSheet.Columns(i).AutoFit
Next i
' Move to first cell to unselect
xlsWSheet.Range("A1").Select


' Show Excel
xlsApp.Visible = True

Set xlsApp = Nothing
Set xlsWBook = Nothing
Set xlsWSheet = Nothing
End Sub

E chame a função assim:

Recorset2Excel Rs_Testes
Tópico encerrado , respostas não são mais permitidas
Voltar