Exportar de VB a XLS, Material del 2000 Opciones

[Admin]

22/febrero/2001

Justamente hace unos minutos alguien me preguntó como exportar datos a Excel .Como he dicho antes , es muy importante que el codigo sea generico y reutilizable.

Aunque a los que no programan mucho esto puede sonarles en chino, les envio un codigo que exporta un recordset ( un resultado) a Excel, sin problemas.

Hay un detalle importante, ustedes encontrarán codigos similares que truenan por una comprobacion "Sobrante" que esta aquí. Estos son los llamados, tipos fuertes, es decir, ustedes no pueden sumar dos cosas de diferente tipo.

Aunque mas adelante veremos a detalle los tipos fuertes, esta funcion es muy sencilla y facil de usar, el secreto es el cstr. Aparentemente sobra, pero si no quieren llevarse en ciertos casos un error 1004 applicattion defined error.

Este código solo considera las primeras 256 columnas pero ampliarlo es simple.

El nombre viene de que convierte de Rs ( recordset ) a Excel (en notación antigua rs2xls)

CODE

Private Sub Rs2XLS(rs As ADODB.Recordset)
Dim d As String

rs.MoveFirst
On Error GoTo etiqueta
    Dim ApExcel As Variant
    Set ApExcel = CreateObject("Excel.application")
    ' Hace que Excel se vea
With ApExcel
    .Visible = True
    'Agrega un nuevo Libro
    .Workbooks.Add
    'Poner Titulos
    Dim x As Integer
    Dim y As Integer
    y = 1
    For x = 1 To rs.Fields.Count
      .cells(y, x).formula = rs.Fields(x - 1).Name
      DoEvents
    Next
    Do Until rs.EOF
      y = y + 1
      For x = 1 To rs.Fields.Count
        Debug.Print x & "/" & y & "/" & rs.Fields(x - 1).Name
        d = Chr(x + 64) & y
        .Range(d).formula = CStr(rs.Fields(x - 1))
        DoEvents
      Next
      rs.MoveNext
      DoEvents
    Loop
    ' Aplica Formula
  '  .cells(3, 4).Formula = "=C2-D2"
    ' Hace una Seleccion de celdas y pone bordes de Color
    '.RANGE("B3:D3").BORDERS.Color = RGB(255, 0, 0)
End With
'xl.quit
    Set ApExcel = Nothing
    Exit Sub
etiqueta:
  If Err.Number = 429 Then
    MsgBox "Parece que su PC no tiene instalado Excel",VbInformation
  Else
    Msgbox Err.Number
  End If
End Sub