** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Tus Funciones Favoritas & Aportaciones & Artí­culos
  Mensajes nuevos Mensajes nuevos RSS - VBA: Access - Excel. Multiples Libros
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoVBA: Access - Excel. Multiples Libros

 Responder Responder
Autor
Mensaje
genoma111 Ver desplegable
Administrador
Administrador
Avatar

Unido: 28/Marzo/2011
Localización: ...
Estado: Sin conexión
Puntos: 3248
Enlace directo a este mensaje Tema: VBA: Access - Excel. Multiples Libros
    Enviado: 27/Septiembre/2013 a las 02:56
Este código permite exportar múltiples libros de Access a Excel y darles formato.

Uso:

Private Sub Command0_Click()

Dim strPath As String
Dim strFile As String
Dim strSQL1 As String
Dim strSQL2 As String

strPath = CurrentProject.Path & "\"
strFile = "SqlsToExcelTest.xlsx"

strSQL1 = "SELECT LastName, ForeName FROM tblAuthors"
strSQL2 = "SELECT PMID, tblPaperID FROM tblAuthors"

Call SqlsToExcel(strPath, strFile, strSQL1, strSQL2)

End Sub

Sub:

Sub SqlsToExcel(strPath As String, _
                strFile As String, _
     ParamArray strSQLs())

On Error GoTo ErrorHandler

    Dim dbs     As DAO.Database
    Dim rst     As DAO.Recordset
    Dim xlAp    As Object
    Dim xlWb    As Object
    Dim xlWs    As Object
    Dim i       As Long
    Dim j       As Long
    Dim j1      As Long
    Dim k       As Long
    Dim x       As Long
    Dim vaHd()  As String
    Dim Data
   
    Set dbs = CurrentDb
    Set xlAp = CreateObject("Excel.Application")
    Set xlWb = xlAp.Workbooks.Add
   
    For i = 0 To UBound(strSQLs)
       
        If i = 0 Then
            Set xlWs = xlWb.Worksheets("Sheet" & i + 1)
        Else
            Set xlWs = xlWb.Worksheets.Add
        End If
       
        Set rst = dbs.OpenRecordset(strSQLs(i))
       
        With rst
            .MoveLast
            j = .Fields.Count
            j1 = j - 1
            k = .RecordCount
            ReDim vaHd(j)
            .MoveFirst

            For x = 0 To j1
                vaHd(x) = .Fields(x).Name
            Next
           
            With xlWb
                xlWs.Cells(1, 1).Resize(1, j) = vaHd
                Data = xlWs.Cells(2, 1).CopyFromRecordset(rst)
            End With
           
            With xlWs
                With .UsedRange
                    .Columns.AutoFit
                    .Rows.AutoFit
                End With
                .ListObjects.Add(1, .Range(.Cells(1, 1), .Cells(k + 1, j)), , 1).Name = "Table" & i + 1
            End With
           
        End With
       
        Set xlWs = Nothing
        Set rst = Nothing
    Next i
  
    xlWb.SaveAs (strPath & strFile)
   
ExitFunction:
    If Not xlWs Is Nothing Then
      Set xlWs = Nothing
    End If
   
    If Not xlWb Is Nothing Then
      Set xlWb = Nothing
    End If

    If Not xlAp Is Nothing Then
      xlAp.Quit
    End If
      
    Exit Sub

ErrorHandler:
    Select Case Err.Number
      Case 0
      Case Else
          MsgBox Err.Number & ": " & Err.Description
          Resume ExitFunction
    End Select
End Sub



Editado por genoma111 - 27/Septiembre/2013 a las 03:26
"To VBA or not to VBA... that's the question" DFP
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable