X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
   Reply to this topicStart new topic
> Excel.querytable Not Working, Office 2007    
post Nov 20 2019, 05:16 AM

Posts: 4
Joined: 4-November 19

This Access code is executing with no errors, but the data is not being populated in the Excel workbook. What am I missing?

Dim Filename As String
Static Path As String
Dim R As Integer
Dim C As Integer
Dim i As Integer
Dim DateColumnCount As Integer
Dim ans As Double
Dim Warehouses As String
Dim Hierarchy As String
Dim MinDate As String
Dim MaxDate As String
Dim Adjust As Boolean
Dim SQLStatement As String
Dim strSQL As String
Dim DBConn As ADODB.Connection
Dim Cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim XLSFile As Excel.Application
Dim LeaveOpen As Boolean

Path = Nz(DFirst("ParameterValue", "tbl_ForecastWH_SalesDataExportDefaults", "Parameter='SalesExportPath'"), "")
If Dir(Left(Path, InStrRev(Path, "\")), vbDirectory) <> "" Then
    Path = Left(Path, InStrRev(Path, "\"))
    Path = ""
End If

LeaveOpen = Forms("frmSalesDataOutput").checkLeaveOpen

Const Q = """"

On Error GoTo ErrorCondition

    'Get the parameters for the query
    Warehouses = ""
    For i = 0 To Forms("frmSalesDataOutput").listWarehouses.listcount - 1
        If Warehouses <> "" Then Warehouses = Warehouses & ","
        Warehouses = Warehouses & Forms("frmSalesDataOutput").listWarehouses.ItemData(i)
    If Warehouses = "" Then
        MsgBox "No warehouses were selected.", vbCritical, "Invalid Parameter"
        GoTo SaveData_Exit
    End If
    Hierarchy = ""
    For i = 0 To Forms("frmSalesDataOutput").listHierachy.listcount - 1
        If Hierarchy <> "" Then Hierarchy = Hierarchy & ","
        Hierarchy = Hierarchy & Forms("frmSalesDataOutput").listHierachy.ItemData(i)
    If Hierarchy = "" Then
        MsgBox "No field were selected in the hierarchy.", vbCritical, "Invalid Parameter"
        GoTo SaveData_Exit
    End If
    MinDate = Forms("frmSalesDataOutput").txtStartDate
    If CDate(MinDate) > Now Then
        MsgBox "The start date is greater than the current date.", vbCritical, "Invalid Parameter"
        GoTo SaveData_Exit
    End If
    MaxDate = Forms("frmSalesDataOutput").txtEndDate
    If CDate(MaxDate) < MinDate Then
        MsgBox "The start date after the end date.", vbCritical, "Invalid Parameter"
        GoTo SaveData_Exit
    End If
    If CDate(MaxDate) > Now Then
        ans = MsgBox("WARNING! The end date selected is greater than the current date.  Insufficent data will be included in the current month's sales data!  Are you sure you wish to continue?", vbExclamation + vbYesNo, "WARNING!")
        If ans <> vbYes Then GoTo SaveData_Exit
    End If
'    Adjust = Forms("frmSalesDataOutput").checkAdjust.Value

    'Get Export Sales Data Filename from user
    With Me!FileDialogControl
        .CancelError = True
        .Filename = "SalesHistory.XLS"
        .InitDir = Path
        .DialogTitle = "Save Sales History Data File"
        .Filter = "xls (*.xls)|*.xls|All Files (*.*)|*.*"
        '.Flags = cdlOFNExplorer + cdlOFNOverwritePrompt + cdlOFNPathMustExist
         Filename = .Filename
         Path = .InitDir
    End With
    If Filename = "" Then
        MsgBox "Data file creation canceled.", vbExclamation, "Canceled"
        GoTo SaveData_Exit
    End If
    'Clear old file
    On Error Resume Next
    Kill Filename
    If err.Number <> 0 And err.Number <> 53 Then 'check for error (ignore if file not found)
        GoTo ErrorCondition
    End If
    Screen.MousePointer = 11 'busy
    Dim XLSFileNew As Excel.Application
    Dim XLSQueryTable As Excel.QueryTable
    Dim SQLCommandString As String
    SQLCommandString = "EXEC sp_ForecastWH_SalesHistory @StartDate='" & MinDate & "', @EndDate='" & MaxDate & "', @WarehouseList='" & Warehouses & "', @HierarchyList='" & Hierarchy & "'"
    'strSQL = "EXEC sp_ForecastWH_SalesHistory  '01/01/07','10/31/19', '01,CA,WS','Total,Warehouse,Item';"
    Set XLSFileNew = New Excel.Application
    XLSFileNew.Workbooks.Add (1)
    XLSFileNew.Visible = LeaveOpen
    If LeaveOpen Then AppActivate XLSFileNew.Caption

'==>Data Not Populating
    Set XLSQueryTable = XLSFileNew.ActiveSheet.QueryTables.Add("ODBC;DRIVER=SQL Server;SERVER=" & CurrentProject.Connection.Properties("Data Source") & ";Trusted_Connection=Yes;APP=2007 Microsoft Office system;DATABASE=" & CurrentProject.Connection.Properties("Initial Catalog"), XLSFileNew.ActiveSheet.Range("A1"), SQLCommandString)
    XLSQueryTable.RefreshStyle = XlCellInsertionMode.xlInsertEntireRows
    XLSQueryTable.Refresh (False)

    XLSFileNew.ActiveWorkbook.Worksheets(1).Name = Format(MaxDate, "mmm-yyyy")
    XLSFileNew.ActiveWorkbook.SaveAs Filename, xlAddIn
    If Not LeaveOpen Then
    End If
    Set XLSFileNew = Nothing
    RunSQL "delete from tbl_ForecastWH_SalesDataExportDefaults where Parameter='checkLeaveOpen';insert into tbl_ForecastWH_SalesDataExportDefaults values ('checkLeaveOpen','" & LeaveOpen & "')"
    RunSQL "delete from tbl_ForecastWH_SalesDataExportDefaults where Parameter='SalesExportPath';insert into tbl_ForecastWH_SalesDataExportDefaults values ('SalesExportPath','" & Filename & "')"
    Screen.MousePointer = 0 'default
    If Not LeaveOpen Then MsgBox "The Sales History file has been created.", vbOKOnly, "Success"


    Screen.MousePointer = 0 'default
    On Error GoTo 0
    DoCmd.Close acForm, "FileDialog"
    Exit Sub


    Screen.MousePointer = 0 'default
    If err.Number = 32755 Then
        MsgBox "Data file creation canceled.", vbExclamation, "Canceled"
        MsgBox "Export file creation failed.  Error: " & err.DESCRIPTION, vbCritical, "Error"
    End If
    DoCmd.Close acForm, "FileDialog"

End Sub
Go to the top of the page
post Nov 20 2019, 06:08 AM

Posts: 156
Joined: 11-October 18

You wouldn't see any errors due to your On Error Resume Next statement. There certainly are some though, such as referring to Worksheets(0) since the indexing starts at 1.
Go to the top of the page

Custom Search

RSSSearch   Top   Lo-Fi    7th December 2019 - 06:07 AM