export from access to excel

[felipedmc]

Hey there! I'm new around here, so I ask for your patience! I tried reading other threads, but none helped me.

My case is: I have lots of tables from wich i need to export data to Excel. These tables countain historical data about pluviometry measured monthly. I biult queryDefs like:

Set objConsulta = CurrentDb.CreateQueryDef(codEstacao & " FEVEREIRO", "SELECT Data,Total FROM " & objTabela.Name & " WHERE Month(Data) = 2")

/*Obs.: in portuguese Data is the english Date. and the english Data is Dado. And Data is a field of my tables. I think you already got this, but it's important to make things clear! hehehe */

Those querys get the data i need monthly. I want to create a single .xlsx for each table i'm querying. Inside these .xlsx I want to have a sheet for each month.
I tried lots of ways to do that, like using recordsets, the methods docmd.outputto() and docmd.transferspreadsheet(). But none worked just right. I'm really struggling and in need of help. So, if you please...!

Rigght now i'm facing the TransferSpreadsheet monster. It does not exports the data i need to the existing excel workbook. It creates another workbook named codEstacao & " FEVEREIRO". Here it its my full vba code:

Public Function criaNome() As String
    
    'Excel objects
        
        Dim objXL As Excel.Application
        Dim objWbk As Excel.Workbook


        
    'Miscelaneous objects
        Dim objTabela As AccessObject
        Dim objConsulta As QueryDef
        Dim rcdSet As Recordset
        Dim fldLoop As Field
        Dim strSQL As String
        Dim strCaminho As String
        
    For Each objTabela In Application.CurrentData.AllTables
        
        If objTabela.Name = "Chuvas" Then
            strSQL = "SELECT DISTINCT EstacaoCodigo FROM " & objTabela.Name
            Set rcdSet = CurrentDb.OpenRecordset(strSQL)
            For Each fldLoop In rcdSet.Fields
                codEstacao = fldLoop.Value
            Next fldLoop
            strCaminho = CurrentProject.Path & "\" & codEstacao '& ".xlsx"
            Set objXL = New Excel.Application
            objXL.SheetsInNewWorkbook = 1
            objXL.Visible = True
            If testaExistenciaArquivo(strCaminho) Then
                Set objWbk = objXL.Workbooks.Open(strCaminho)
                objWbk.Save
            Else
                Set objWbk = objXL.Workbooks.Add
                objWbk.SaveAs FileName:=strCaminho, ReadOnlyRecommended:=False
            End If
            
            'JANEIRO
                 Set objConsulta = CurrentDb.CreateQueryDef(codEstacao & " JANEIRO", "SELECT Data,Total FROM " & objTabela.Name & " WHERE Month(Data) = 1")
                 DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, objConsulta.Name, strCaminho & "!" & codEstacao & " JANEIRO" & ".xlsx"
            'FEVEREIRO
            Set objConsulta = CurrentDb.CreateQueryDef(codEstacao & " FEVEREIRO", "SELECT Data,Total FROM " & objTabela.Name & " WHERE Month(Data) = 2")
            DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, objConsulta.Name, strCaminho & "!" & codEstacao & " FEVEREIRO" & ".xlsx"
    End If
    Next objTabela        


End Function

 

[SydneyGeek]

Hi Felipe,
I found some code and adapted it. This created a workbook (or overwrote an existing one) and created or overwrote the worksheets as well.
I have left all the original comments in place.
Note: works for .xls -- I need to find the code to make it work for .xlsx

Sub AdaptedFromTheNet()
    ''ORIGINAL SOURCE: EXCEL Export
    ''Modified by Denis Wright
    ''Writes data to a series of defined worksheets, creating the sheets
    ''  if they do not already exist.
    
    Dim qdf As DAO.QueryDef
    Dim dbs As DAO.Database
    Dim rstMonth As DAO.Recordset
    Dim strSQL As String, _
        strTemp As String, _
        strMonthName As String
    
    ' Replace PutEXCELFileNameHereWithoutdotxls with actual EXCEL
    ' filename without the .xls extension
    ' (for example, MyEXCELFileName, BUT NOT MyEXCELFileName.xls)
    Const strFileName As String = "ExportTest"
    
    Const strQName As String = "zExportQuery"
    
    Set dbs = CurrentDb
    
    ' Create temporary query that will be used for exporting data;
    ' we give it a dummy SQL statement initially (this name will
    ' be changed by the code to conform to each manager's identification)
    strTemp = dbs.TableDefs(0).Name
    strSQL = "SELECT * FROM [" & strTemp & "] WHERE 1=0;"
    Set qdf = dbs.CreateQueryDef(strQName, strSQL)
    qdf.Close
    strTemp = strQName
    
    ' *** code to set strSQL needs to be changed to conform to your
    ' *** database design -- ManagerID and EmployeesTable need to
    ' *** be changed to your table and field names
    ' Get list of ManagerID values -- note: replace my generic table and field names
    ' with the real names of the EmployeesTable table and the ManagerID field
    strSQL = "SELECT DISTINCT Format(AT_Firstday,""MMMM"") AS MonthName, AT_Month FROM AllTime ORDER BY AT_Month;"
    Set rstMonth = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)
    
    ' Now loop through list of ManagerID values and create a query for each ManagerID
    ' so that the data can be exported -- the code assumes that the actual names
    ' of the managers are in a lookup table -- again, replace generic names with
    ' real names of tables and fields
    If rstMonth.EOF = False And rstMonth.BOF = False Then
          rstMonth.MoveFirst
          Do While rstMonth.EOF = False
    
    ' *** code to set strMonthName needs to be changed to conform to your
    ' *** database design -- ManagerNameField, ManagersTable, and
    ' *** ManagerID need to be changed to your table and field names
    ' *** be changed to your table and field names
                strMonthName = rstMonth!MonthName
    
    ' *** code to set strSQL needs to be changed to conform to your
    ' *** database design -- ManagerID, EmployeesTable need to
    ' *** be changed to your table and field names
                strSQL = "SELECT * FROM AllTime WHERE " & _
                      "AT_Month = " & rstMonth!AT_Month & " AND AT_Year = 2012;"
                Set qdf = dbs.QueryDefs(strTemp)
                qdf.Name = strMonthName
                strTemp = qdf.Name
                qdf.SQL = strSQL
                qdf.Close
                Set qdf = Nothing
    
    ' Replace C:\FolderName\ with actual path
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
                      strTemp, CurrentProject.Path & "\" & strFileName & ".xls"
                rstMonth.MoveNext
          Loop
    End If
    
    rstMonth.Close
    Set rstMonth = Nothing
    
    dbs.QueryDefs.Delete strTemp
    dbs.Close
    Set dbs = Nothing
End Sub

Note: The routine creates and destroys temporary queries for the export. As part of the recordset that loops through the months, the month names are also created from existing dates.

Denis

 

[felipedmc]

I see. But in my case I don't want to destroy existing worksheets. In my tables I have data about every first month day since 1950's. So my recordset would be like

Date (dd/mm/yyyy) Total
01/01/1953 126
01/02/1953 150
... ...
01/01/1954 100
01/02/1955 130

So when it's the first record, the data must be inserted into the JANUARY sheet, then the second record into FEB sheet, and so it goes. Got it?
I can't destroy my worksheet everytime, i must just add the data to the correct sheet.

Thanks for the help. I'm eager to solve this crap!

 

[SydneyGeek]

The only way I know to do that is by using ADO. I would drive it from Excel, not from Access, using code in the target workbook.
See here for examples of transferring data between Excel and Access, using Excel as the driver.
You need to loop through the sheets (use an array), filtering the data for each month, and using CopyFromRecordset to insert data into the first unused row.

Denis

 

[felipedmc]

So i made by setting my recordset with a diferent SQL for each month. But one of the fields is a date type, and instead of just exporting the field as it is, in the excel worsheet it appears as ######## instead of 01/01/1957 for example. What is going on? here's my code:

Public Function createFillWorkbooks() As String
    
    'Excel objects
        
        Dim objXL As Excel.Application
        Dim objWbk As Excel.Workbook
        Dim objWks As Excel.Worksheet
        Dim objRng As Excel.Range
        
        
    'Miscelaneous objects
        Dim objTable As AccessObject
        Dim rcdSet As Recordset
        Dim qryDef As QueryDef
        Dim codMon As Integer
        Dim codSt As String
        Dim strPath As String
        Dim strSheetName As String
        Dim strRng As String
        Dim strMon As String
        Dim strSQL As String
        
    For Each objTable In Application.CurrentData.AllTables
        If (objTable.Name = "Chuvas") Then
            Debug.Print (objTable.Name)
            strSQL = "SELECT DISTINCT EstacaoCodigo as stCode FROM " & objTable.Name
            Set rcdSet = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
            codSt = rcdSet!stCode
            If rcdSet.RecordCount <> 1 Then
                Debug.Print "More than one station in table " & objTable.Name
                rcdSet.MoveFirst
            End If
            strPath = CurrentProject.Path & "\" & codSt & ".xls"
            Set objXL = New Excel.Application
            objXL.SheetsInNewWorkbook = 1
            objXL.Visible = True
            If testFileExistence(strPath) Then
                Set objWbk = objXL.Workbooks.Open(strPath)
                objWbk.Save
            Else
                Set objWbk = objXL.Workbooks.Add
                objWbk.SaveAs FileName:=strPath, ReadOnlyRecommended:=False
            End If
            objWbk.Activate
            Set rcdSet = Nothing
            
            For codMon = 1 To 12
                strSQL = "SELECT Data,Total FROM " & objTable.Name & " WHERE Month(Data) = " & codMon
                Set rcdSet = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
                If testSheetExistence(codSt & MonthName(codMon)) Then
                    Set objWks = objWbk.Sheets(codSt & MonthName(codMon))
                Else
                    Set objWks = objWbk.Sheets.Add
                    objWks.Name = codSt & MonthName(codMon)
                End If
                If testSheetExistence("Sheet1") Then
                    objWbk.Sheets("Sheet1").Delete
                End If
                Set objRng = objWks.Range("A1")
                objRng.CopyFromRecordset rcdSet
                Set rcdSet = Nothing
            Next codMon
        End If
    Next objTable
End Function

 

[SydneyGeek]

Sometimes Access and Excel don't communicate well with dates.
What happens if you change the format of that column?

I noticed in your code that you are populating from A1. If that's the case, the Transferpreadsheet code I gave you will give the same result. Sheets that already exist are overwritten (not trashed and recreated). Sheets that don't exists are created on the fly. You can check that by building a simple formula that references one of the sheets. Once you update you should get a value, not a REF error.

Denis

 

[felipedmc]

the transferspreadsheet method you gave me was popping a run time error. it was something like "external database error".idon't remeber the error code tough. My code actually worked just fine. the ### were being displayed because of the column width. i just set the activeworksheet.columns.autofit method after populating the worksheet with my recordset and it worked. Nowi gotta navigate trough every workbook (when i download all the tables, it will be around 400 worbooks),and through every worksheet calculating the "total"column average and saving it to a new workbook. That is this week's goal now!thanks for the help. Awesome forum!

 

[SydneyGeek]

You're welcome, glad to help.

Denis