** 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. Exporta Múltiples SQLs
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoVBA: Access - Excel. Exporta Múltiples SQLs

 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. Exporta Múltiples SQLs
    Enviado: 09/Noviembre/2013 a las 19:54
Exporta múltiples cadenas VBA-SQL a Excel en un solo tiempo
Uso:

Private Sub Command0_Click()
    Dim strPath As String
    Dim strFile As String
    Dim strSQL1 As String
    Dim strSQL2 As String
    Dim strSQL3 As String
   
    strPath = CurrentProject.Path & "\"
    strFile = "SqlsToExcelTest.xlsx"
   
    strSQL1 = "SELECT LastName, ForeName FROM tblAuthors" & "|SpreadSheet1"
    strSQL2 = "SELECT PMID, tblPaperID FROM tblAuthors" & "|SpreadSheet2"
    strSQL3 = _
            "SELECT LastName, ForeName FROM tblAuthors " & _
            "UNION " & _
            "SELECT LastName, ForeName FROM tblAuthors2 " & _
            "UNION " & _
            "SELECT LastName, ForeName FROM tblAuthors3;"
   
    Call SqlsToExcel(strPath, strFile, strSQL1, strSQL2, strSQL3)
   
End Sub

Función:

'-------------------------------------------------------------------------------------------
' Name:         SqlsToExcel
' Purpose:      Exporta múltiples VBA-SQLs a diferentes hojas de datos en Excel.
' Description:  strPath = La ruta completa.
'               strFile = El nombre del archivo.
'               strSQLs = ParamArray. Las cadenas VBA-SQL.
'                         Utiliza la barra para separar el nombre de la hoja.
'                         p.e. SQL1|Nombre de la hoja
' Author:       Diego F.Pereira-Perdomo
' Date:         Sep-26-2013
'-------------------------------------------------------------------------------------------
Option Compare Database
Option Explicit

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
    Dim strSQL  As String
    Dim strName As String
    Dim aSQL
   
    Set dbs = CurrentDb
    Set xlAp = CreateObject("Excel.Application")
    Set xlWb = xlAp.Workbooks.Add
   
    For i = 0 To UBound(strSQLs)
       
        aSQL = Split(strSQLs(i), "|")
             
        If UBound(aSQL) < 1 Then
            strSQL = Trim(aSQL(0))
            strName = "Sheet" & i + 1
        Else
            strSQL = Trim(aSQL(0))
            strName = Trim(aSQL(1))
        End If
       
        Set rst = dbs.OpenRecordset(strSQL)
       
        With rst
       
            If Not .EOF And Not .BOF Then
       
                If i = 0 Then
                    Set xlWs = xlWb.Worksheets("Sheet" & i + 1)
                    xlWs.Name = strName
                Else
                    Set xlWs = xlWb.Worksheets.Add
                    xlWs.Name = strName
                End If
           
                .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 If
           
        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

"To VBA or not to VBA... that's the question" DFP
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable