HI Kyle
My SQL is about 400 lines long, is quite complicated and not an issue so I won't post it to save causing confusion.
My VBA - which runs fine, apart from returning the date values as text - is as follows.
The table column the data is pasted into is formatted as 'MMM YYYY', and all preceding columns are formatted as GENERAL.
Option Explicit
'Module wide variables
Dim shtVar As Worksheet 'pointer to worksheet storing variables
Dim shtOut As Worksheet 'pointer to the results worksheet
Dim tblOut As ListObject 'pointer to the results table (list object)
Dim rngOut As Range 'pointer to the results range
Dim strCxn As String 'connection string for the query
Dim strSQL As String 'the query's SQL text
Dim strStatus As String 'Status Bar message
Dim booStatus As Boolean 'current status bar state
Dim dteStart As Date 'time query started
'==============================================================================
Sub Run_a_data_query()
'Assumes connection string to be used is stored in the workbook as a range name
'==============================================================================
If MsgBox("Do you want to run the 'Update Balance Sheet data' query ?", _
vbYesNo, _
"RUN QUERY ? ...") <> vbYes Then
Exit Sub
Else 'run the query
'setup the Excel working environment
Call SetupSubEnvironment
'set up variables & objects
'==========================
dteStart = Now 'store start time
Set shtVar = Worksheets("Inputs_Constants")
Set shtOut = Worksheets("SQL data")
Set tblOut = shtOut.ListObjects("tblActualsData")
Set rngOut = Range(tblOut).Cells(1, 1)
'store the SQL code, connection string & status bar text
'NOTE: The SQL is split over 2 cells as I cannot paste all of it into one cell
strSQL = shtVar.Range("qryData_1").Value & shtVar.Range("qryData_2").Value
strCxn = shtVar.Range("cxnData").Value
strStatus = "Running query 'Update Balance Sheet data'; please wait..."
'clear any active table filters
Call Clear_Table_Filters
'delete any existing records from the table
Call Delete_Table_Body
'run the query
Call Run_Query
'then reset the Excel working environment
Call ResetSubEnvironment
Beep 'to tell the user the procedure has completed
shtOut.Activate
MsgBox "The query has successfully completed, and took " & _
Format(Now - dteStart, "h\h:mm\m:ss\s") & " to run.", _
vbInformation + vbOKOnly, _
"QUERY COMPLETE..."
End If
End Sub '**********************************************************************
'==============================================================================
Sub Run_Query()
'==============================================================================
On Error Resume Next 'turn on error trap
'Store Current Query to Check For Errors
Dim objCxn As ADODB.Connection
Dim objRecSet As ADODB.Recordset
If Err.Number <> 0 Then
MsgBox "The ActiveX Data Objects library isn't connected to this file." & _
vbCr & vbCr & _
"In the VBA Editor, select the Tools | References options, " & _
"select the Microsoft ActiveX Data Objects library & try again.", _
vbOKOnly + vbCritical, _
"NO CONNECTION TO ActiveX Data Objects Library..."
'turn off error trap
On Error GoTo 0
Exit Sub
End If
'continue here if ADODB variables created...
Application.Calculation = xlCalculationManual
'Create the Connection and Recordset objects
Set objCxn = New ADODB.Connection
Set objRecSet = New ADODB.Recordset
' Open the connection and execute; On Error trap should still be active...
With objCxn
.CommandTimeout = 0
.Open strCxn
End With
If Err.Number <> 0 Then
MsgBox "The ActiveX Data Objects connection could not be opened." & _
vbCr & vbCr & _
"In the VBA Editor, select the Tools | References options, " & _
"select the Microsoft ActiveX Data Objects library & try again.", _
vbOKOnly + vbCritical, _
"ADODB CONNECTION COULD NOT BE OPENED..."
Application.Calculation = xlCalculationAutomatic
'turn off error trap
On Error GoTo 0
Exit Sub
End If
'Continue here if connection was able to be opened.
'Turn off error trap, as there should be no more trappable errors
On Error GoTo 0
Set objRecSet = objCxn.Execute(strSQL)
'Check we have data...
If Not objRecSet.EOF Then
'then store the result to the output range, ...
rngOut.CopyFromRecordset objRecSet
'and close the record set
objRecSet.Close
Else
MsgBox "The query returnd NO records.", vbCritical, "ERROR..."
End If
'release the query's object pointers
Set objCxn = Nothing
Set objRecSet = Nothing
Application.Calculation = xlCalculationAutomatic
End Sub '**********************************************************************
'==============================================================================
Sub SetupSubEnvironment()
'==============================================================================
With Application
'Set interface options
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
'setup Status Bar
booStatus = Application.DisplayStatusBar
.DisplayStatusBar = True
'Set Mouse Cursor to Wait
.Cursor = xlWait
End With
End Sub '**********************************************************************
'==============================================================================
Sub ResetSubEnvironment()
'==============================================================================
With Application
'Reset Mouse Cursor
Application.Cursor = xlDefault
'Reinstate original StatusBar
.StatusBar = False
.DisplayStatusBar = booStatus
'Reset interface options
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
Set shtVar = Nothing
End Sub '**********************************************************************
'==============================================================================
Sub Delete_Table_Body()
'If data rows exist on table tblOut, delete them (keeping any table formulas)
'==============================================================================
With tblOut
If Not .DataBodyRange Is Nothing Then
.DataBodyRange.Delete
End If
End With
End Sub '**********************************************************************
'==============================================================================
Sub Clear_Table_Filters()
'If a filter on sheet shtOut's table tblOut exists, clear it
'==============================================================================
If shtOut.FilterMode = True Then
tblOut.Range.AutoFilter
End If
End Sub '**********************************************************************
'==============================================================================
Sub Clear_Sheet_Filters(sht As Worksheet)
'clear any Auto Filters on sheet 'sht'
'==============================================================================
With sht
On Error Resume Next
.ShowAllData
On Error GoTo 0
End With
End Sub '**********************************************************************
