Solved Access export to excel (1 Viewer)

[CosmaL]

Dear friends,

i've got the following code for exporting a query to a workbook.

I would like to have another sheet with informations.

The problem is that the book is always recreated and if i use it as a template, all the sheets are always deleted.

Any ideas? I'd like to have 2 sheets, 1 the exported query and the 2nd the information sheet which always will be in the file.


Dim objXl As Object
Dim objActiveWkb As Object

stDocName = "Invoices"

filename = "C:\Temp" & "\" & stDocName

DoCmd.OutputTo acQuery, stDocName, acFormatXLSX, filename, , "Invoices.xlsx", , acExportQualityPrint 'Transfer is not working, i always get doublivated sheet

Set objXl = CreateObject("Excel.Application")
Set objActiveWkb = objXl.Workbooks.Open("c:\temp\Invoices.xlsx")

With objActiveWkb.Sheets("Invoices") 'Formatting workbook
.Rows("1:1").Font.Bold = True
.Columns("A:A").ColumnWidth = 30
.Columns("A:A").Font.Bold = True
.Columns("A:A").Font.Color = vbRed
.Columns("B:B").ColumnWidth = 12
.Columns("B:B").HorizontalAlignment = xlCenter
.Columns("c:c").ColumnWidth = 23
.Columns("d:d").ColumnWidth = 60
.Columns("e:e").ColumnWidth = 20
.Columns("f:f").ColumnWidth = 10
.Columns("f:f").HorizontalAlignment = xlCenter
.Columns("g:g").ColumnWidth = 18
.Columns("h:h").ColumnWidth = 20
.Columns("i:i").ColumnWidth = 20
.Columns("j:j").ColumnWidth = 18
.Columns("j:j").HorizontalAlignment = xlCenter
.Columns("k:k").ColumnWidth = 20
End With

objActiveWkb.Close SaveChanges:=True
Set objActiveWkb = Nothing
Set objXl = Nothing


Thank you in advance!!!!

 

[arnelgp]

add this two function to a Module or to the Form module:

Function GetLastRow(ByRef Sht As Object, ByVal strColumn As String) As Long
    Dim MyRange As Object   'Range
    Const xlUp As Integer = -4162
    Set MyRange = Sht.Range(strColumn & "1")
    GetLastRow = Sht.Cells(Rows.count, MyRange.Column).End(xlUp).Row
End Function

Public Function write_header(ByRef Sht As Object, ByVal Column As String, ByRef RS As DAO.Recordset)
    ' write column header
    Dim i As Integer
    Dim j As Integer
    j = RS.Fields.count - 1
    With Sht
        For i = 0 To j
            .Range("A" & i + 1).Value = RS(i).Name
        Next
    End With
End Function

this is your code:

Dim objXl As Object         'Excel.Application
Dim objActiveWkb As Object  'Excel.Workbook
Dim InvoiceSheet As Object  'Excel.Worksheet
Dim InfoSheet As Object     'Excel.Worksheet
Dim db As DAO.Database
Dim RS As DAO.Recordset
Dim bolNew As Boolean
Dim sFileName As String
Dim lngLastRow As Long

Const stDocName As String = "Query1" '"Invoices"

sFileName = "C:\Temp" & "\" & stDocName & ".xlsx"
'sFileName = "d:\" & stDocName & ".xlsx"

'arnelgp
'DoCmd.OutputTo acQuery, stDocName, acFormatXLSX, FileName, , "Invoices.xlsx", , acExportQualityPrint 'Transfer is not working, i always get doublivated sheet


Set objXl = CreateObject("Excel.Application")

' check if the workbook already exists
If Dir(sFileName) <> "" Then
    Set objActiveWkb = objXl.Workbooks.Open(sFileName)
Else
    Set objActiveWkb = objXl.Workbooks.Add
    bolNew = True
End If
' check if the worksheet exits
On Error Resume Next
'Set InvoiceSheet = objActiveWkb.Worksheets(stDocName)
Set InvoiceSheet = objActiveWkb.Worksheets("Invoices")
If Err.Number <> 0 Then
    Err.Clear
    Set InvoiceSheet = objActiveWkb.Worksheets.Add
    InvoiceSheet.Name = stDocName
End If
Set InfoSheet = objActiveWkb.Worksheets("Info Sheet")
If Err.Number <> 0 Then
    Err.Clear
    Set InfoSheet = objActiveWkb.Worksheets.Add(After:=InvoiceSheet)
    InfoSheet.Name = "Info Sheet"
End If
On Error GoTo 0

Set db = CurrentDb
Set RS = db.OpenRecordset(stDocName)
InvoiceSheet.Select
With InvoiceSheet 'Formatting workbook
    lngLastRow = GetLastRow(InvoiceSheet, "A")
    If lngLastRow = 1 Then
        'write the column header
        Call write_header(InvoiceSheet, "A", RS)
    End If
    .Range("A" & lngLastRow + 1).CopyFromRecordset RS
    .Rows("1:1").Font.Bold = True
    .Columns("A:A").ColumnWidth = 30
    .Columns("A:A").Font.Bold = True
    .Columns("A:A").Font.Color = vbRed
    .Columns("B:B").ColumnWidth = 12
    .Columns("B:B").HorizontalAlignment = xlCenter
    .Columns("c:c").ColumnWidth = 23
    .Columns("d:d").ColumnWidth = 60
    .Columns("e:e").ColumnWidth = 20
    .Columns("f:f").ColumnWidth = 10
    .Columns("f:f").HorizontalAlignment = xlCenter
    .Columns("g:g").ColumnWidth = 18
    .Columns("h:h").ColumnWidth = 20
    .Columns("i:i").ColumnWidth = 20
    .Columns("j:j").ColumnWidth = 18
    .Columns("j:j").HorizontalAlignment = xlCenter
    .Columns("k:k").ColumnWidth = 20
End With
Set InvoiceSheet = Nothing
Set InfoSheet = Nothing
If bolNew Then
    objActiveWkb.Close savechanges:=True, FileName:=sFileName
Else
    objActiveWkb.Close savechanges:=True
End If
Set objActiveWkb = Nothing
objXl.Quit
Set objXl = Nothing
RS.Close
Set RS = Nothing
Set db = Nothing

 

[Isaac]

Another option that would require a lot less code:
1. in your vba, assign a new (never before used) strPath for the output file. (maybe "c:\folder\" & format(now,mmddyyhhmmss) & ".xlsx"
2. in your OutputTo code, output to that new file
3. use a few lines of code to copy strPath 's sheet, over to your Master book.

Less code and no looping.

 

[CosmaL]

Thanks! It's working!

 

[Isaac]

Good luck!