Forma de uso:
SQLStmt = "select top 20* from calendar"
RS.Open SQLStmt, Con, adOpenStatic
Rec2Excel SQLStmt, Con
RS.Close
(No olvidar incluir el archivo
adovbs.inc)
Código:
Sub Rec2Excel(xRecordSet, Con)
'This SubRoutine will Print the Data in any Recordset to Excel,
'be it a SQL statement or valid Recordset Table Name.
Dim I
Dim RS
Dim exc
Set RS = server.CreateObject("ADODB.Recordset")
RS.Open xRecordSet, Con, adOpenStatic, adLockReadOnly
Set exc = server.CreateObject("Excel.Application")
exc.Workbooks.Add
exc.Visible = True
With exc
For I = 0 To RS.Fields.Count - 1
.Cells(1, I + 1) = RS(I).Name
Next
I = 1
While Not RS.EOF
I = I + 1
For j = 0 To RS.Fields.Count - 1
If RS(j).Type = adVarChar Or RS(j).Type = adChar Then
If IsNull(RS(j)) Then
.Cells(I, j + 1) = ""
Else
.Cells(I, j + 1) = Trim(RS(j))
End If
.Cells(I, j + 1).Borders.LineStyle = xlDouble
.Cells(I, j + 1).Borders.Color = vbBlue
ElseIf RS(j).Type = adDecimal Or RS(j).Type = adNumeric Or
RS(j).Type = adInteger Then
If IsNull(RS(j)) Then
.Cells(I, j + 1) = ""
Else
.Cells(I, j + 1) = Str(RS(j))
End If
.Cells(I, j + 1).Borders.LineStyle = xlDouble
.Cells(I, j + 1).Borders.Color = vbBlue
End If
Next
RS.MoveNext
Wend
.Range("A1:" & Chr(65 + j) & 1).Font.Bold = True
.Range("A1:" & Chr(65 + j) & 1).Font.Color = vbRed
.Range("A1:" & Chr(65 + j) & 1).Borders.LineStyle = xlDouble
'.Range("A1:" & Chr(65 + j) & 1).Borders
' .Color = vbRed
.Columns("$A:" & "$" & Chr(65 + j)).AutoFit
End With
Set RS = Nothing
End Sub
Aunque hay programas que hacen eso de forma mas o menos buena
Un saludo