Save an Excel Workbook from Code

[koolwaters]

Hi!

The code below is used to export data from an Access table to a specific cell in an Excel worksheet.

Public Sub ExpExcel()
Dim cnn As ADODB.Connection
Dim MyRecordset As New ADODB.Recordset
Dim MySQL As String
Dim MySheetPath As String
Dim Xl As Object
Dim XlBook As Object
Dim XlSheet As Object
Dim db As DAO.Database
Set cnn = CurrentProject.Connection

MyRecordset.ActiveConnection = cnn

    If Not IsNothing(Me.StartDate) Then
        If Not IsDate(Me.StartDate) Then
            MsgBox "You must enter a valid 'Beginning' date.", vbExclamation, gstrAppTitle
            Me.StartDate.SetFocus
            Exit Sub
        End If
    End If
    If Not IsNothing(Me.EndDate) Then
        If Not IsDate(Me.EndDate) Then
            MsgBox "You must enter a valid 'Ending' date.", vbExclamation, gstrAppTitle
            Me.EndDate.SetFocus
            Exit Sub
        End If

        If Not IsNothing(Me.StartDate) Then
            If Me.EndDate < Me.StartDate Then
                MsgBox "'Ending' Date must not be earlier than 'Beginning' Date.", _
                    vbExclamation, gstrAppTitle
                Me.EndDate.SetFocus
                Exit Sub
            End If
        End If
    End If


DoCmd.SetWarnings False
DoCmd.OpenQuery ("qmtblXptFundingBySegmentRawData")
MySQL = "SELECT * FROM tblXptFundingBySegmentRawData;"
MyRecordset.Open MySQL

MySheetPath = GetFEPath & "Excel Files\Payments Allocated Raw Data.xltx"

Set Xl = CreateObject("Excel.Application")
Set XlBook = GetObject(MySheetPath)

Xl.Visible = True
XlBook.Windows(1).Visible = True
XlBook.Activate = True

Set XlSheet = XlBook.Worksheets("RawData")
XlSheet.Range("RangeRawData").ClearContents
XlSheet.Range("A4").CopyFromRecordset MyRecordset

Set XlSheet = XlBook.Worksheets("Main")
XlSheet.Range("B12") = "Payments Allocated Raw Data for the period " & Format(StartDate, "dd-mmm-yyyy") & " to " & Format(EndDate, "dd-mmm-yyyy")
XlBook.SaveAs GetFEPath & "Excel Files\Payments Allocated Raw Data- " & Format(Now(), "dd-mmm-yyyy") & ".xlsx"
    
MyRecordset.Close
MyRecordset.Close
Set cnn = Nothing
Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing

DoCmd.SetWarnings True

End Sub

The code works fine with the exception of the SaveAs .

XlBook.SaveAs GetFEPath & "Excel Files\Payments Allocated Raw Data- " & Format(Now(), "dd-mmm-yyyy") & ".xlsx"

I just want to be able to save the template but the workbook opens but it is not saved with the new name.

The database is split and GetFEPath returns the path of the frontend.

Thanks for any help.

 

[koolwaters]

To Xenou:

Based on what you said regarding the template, I change the file to an excel workbook

MySheetPath = GetFEPath & "Excel Files\Payments Allocated Raw Data.xlsx"

That seems to have done the trick. This is the code that I have used and I have just added a few lines to delete the file if it one exists with the name I want to Save with before the SaveAs is executed. Just need to add my error handling.

Public Sub ExpExcel()
Dim cnn As ADODB.Connection
Dim MyRecordset As New ADODB.Recordset
Dim MySQL As String
Dim MySheetPath As String
Dim MySavePath As String
Dim Xl As Object
Dim XlBook As Object
Dim XlSheet As Object
Dim db As DAO.Database
Set cnn = CurrentProject.Connection

MyRecordset.ActiveConnection = cnn

    If Not IsNothing(Me.StartDate) Then
        If Not IsDate(Me.StartDate) Then
            MsgBox "You must enter a valid 'Beginning' date.", vbExclamation, gstrAppTitle
            Me.StartDate.SetFocus
            Exit Sub
        End If
    End If
    If Not IsNothing(Me.EndDate) Then
        If Not IsDate(Me.EndDate) Then
            MsgBox "You must enter a valid 'Ending' date.", vbExclamation, gstrAppTitle
            Me.EndDate.SetFocus
            Exit Sub
        End If

        If Not IsNothing(Me.StartDate) Then
            If Me.EndDate < Me.StartDate Then
                MsgBox "'Ending' Date must not be earlier than 'Beginning' Date.", _
                    vbExclamation, gstrAppTitle
                Me.EndDate.SetFocus
                Exit Sub
            End If
        End If
    End If


DoCmd.SetWarnings False
DoCmd.OpenQuery ("qmtblXptFundingBySegmentRawData")
MySQL = "SELECT * FROM tblXptFundingBySegmentRawData;"
MyRecordset.Open MySQL

MySheetPath = GetFEPath & "Excel Files\Payments Allocated Raw Data.xlsx"
MySavePath = GetFEPath & "Excel Files\Payments Allocated Raw Data, " & Format(Now(), "dd-mmm-yyyy") & ".xlsx"

Set Xl = CreateObject("Excel.Application")
Set XlBook = GetObject(MySheetPath)

Xl.Visible = True
XlBook.Windows(1).Visible = True
XlBook.Activate = True

Set XlSheet = XlBook.Worksheets("RawData")
XlSheet.Range("RangeRawData").ClearContents
XlSheet.Range("A4").CopyFromRecordset MyRecordset

Set XlSheet = XlBook.Worksheets("Main")
XlSheet.Range("B12") = "Payments Allocated Raw Data for the period " & Format(StartDate, "dd-mmm-yyyy") & " to " & Format(EndDate, "dd-mmm-yyyy")

If "" <> Dir(MySavePath) Then
    Kill MySavePath
End If

XlBook.SaveAs MySavePath
    
MyRecordset.Close
MyRecordset.Close
Set cnn = Nothing
Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing

DoCmd.SetWarnings True

End Sub

To Norie:

C is my Windows 7 partition and D is my Vista partition on my laptop.

Thanks as usual for all of the help. It is appreciated.