Running An Access Query Using Excel VBA

[RunTime91]

Hello...

I have the following code in my Excel VBE attached to a button that when clicked runs a query in Access then places the results into an Excel sheet

It works perfectly, but only so far as I hard code the date of the data I want returned in the Access query.

Naturally, I need the query to return data based upon a date entered into a cell in my Excel sheet.

I've tried several solutions (using parameters and other types of variables) which have resulted in several types of errors.

The Sheet.Range where the date will be entered is: Sheets("DataEntry").Range("D5") - Which you will see referenced (commented out) in the code as a TargetRange Variable.

Thank you so much for any help - Also, I have cross posted this in the Access forum as I'm not sure which one this question belongs to.

Sub RunRepository()Dim Con As Object
Dim Rs As Object
Dim AccessFile As String
Dim TargetRange As Range
Dim i As Integer
Dim Cmd As ADODB.Command
Dim StrQuery As String

Application.ScreenUpdating = False

AccessFile = ("N:\Referral Management (RAOC)\Internal\@DeptCommon\MorningRpt\MorningRpt.accdb")
StrQuery = "QryTest"

On Error Resume Next

Set Con = CreateObject("ADODB.Connection")
If Err.Number <> 0 Then
  MsgBox ("Connection was not created")
  Exit Sub
End If
On Error GoTo 0
With Con
  .Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
End With

'''''Set TargetRange = Sheets("DataEntry").Range("D5")
'''''With Cmd
'''''  .Parameters = ("Prm")
'''''End With

Set Rs = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
  Set Rs = Nothing
  Set Con = Nothing
  
  MsgBox ("Recordset was not created")
  Exit Sub
End If
On Error GoTo 0
Rs.Open StrQuery, Con
 'Check if the recordet is empty.
    If Rs.EOF And Rs.BOF Then
        'Close the recordet and the connection.
        Rs.Close
        Con.Close
        'Release the objects.
        Set Rs = Nothing
        Set Con = Nothing
        'Enable the screen.
        Application.ScreenUpdating = True
        'In case of an empty recordset display an error.
        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
        Exit Sub
    End If
Sheets("Repository").Range("A2").CopyFromRecordset Rs

Rs.Close
Con.Close 

End Sub

 

[RunTime91]

UPDATE:

The code below works but only if I hard code the date - Which, of course will not work...

Some unexplainable things here include why does this work when I did not change the CommandType or the CommandText references which point to the Query in Access

Even though the variable DateInput seems to be set - When I run the code with DateInput in place of the hard coded date I get a: "No value given for one or more required parameters"

In fact when I put DateInput in the Immediate window it comes back blank

Sub RunRepository()Dim Con As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim AccessFile As String
Dim TargetRange As Range
Dim Cmd As ADODB.Command
Dim StrSQL As String

Application.ScreenUpdating = False
AccessFile = ("N:\Referral Management (RAOC)\Internal\@DeptCommon\MorningRpt\MorningRpt.accdb")

On Error Resume Next

Set Con = New ADODB.Connection

If Err.Number <> 0 Then
  MsgBox ("Connection was not created")
  Exit Sub
End If

On Error GoTo 0

With Con
  .Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
End With

Set Cmd = CreateObject("ADODB.Command")

With Cmd
  .ActiveConnection = Con
    .CommandType = adCmdStoredProc
      .CommandText = "QryFx3"
    .Parameters.Append .CreateParameter("DateInput", adDate, adParamInput, , Sheets("DataEntry").Range("D5").Value)
  Set Rs = .Execute()
End With

Set Rs = New ADODB.Recordset

If Err.Number <> 0 Then
  Set Rs = Nothing
    Set Con = Nothing
    MsgBox ("Recordset was not created")
  Exit Sub
End If

On Error GoTo 0

StrSQL = "SELECT [TblInvCOB].COBDate AS COBDate, " & _
          "(Round(([TblInvCOB].[104_FxdUrg]+[TblInvCOB].[105_FxdRout])*0.6)) AS [23_RefFaxBacks], " & _
          "([TblInvCOB].[103_FxdEDI]+[TblInvCOB].[104_FxdUrg]+[TblInvCOB].[105_FxdRout])-[23_RefFaxBacks] AS [24_AuthFaxBacks], " & _
          "[TblInvCOB].[102_ReturnedMail] AS [25_ReturnedMail] " & _
          "FROM TblInvCOB " & _
          "WHERE(([TblInvCOB].COBDate) = DateInput);"

Rs.Open StrSQL, Con

            'Check if the recordet is empty.
    
If Rs.EOF And Rs.BOF Then
            'Close the recordet and the connection if empty.
        Rs.Close
        Con.Close
            'Release the objects.
        Set Rs = Nothing
        Set Con = Nothing
            'Enable screen.
        Application.ScreenUpdating = True
            'In case of an empty recordset display an error.
        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
    End If

Sheets("Repository").Range("A2").CopyFromRecordset Rs

Rs.Close
Con.Close

End Sub

 

[RunTime91]

Correction to UPDATE

The above showed the DateInput variable which, when I insert that, the code pulls the "No value given..." error.

Below is the only way I can get this code to work - Also, you may notice I tried to set the DateInput variable, which, while it did allow me to pull a date from DateInput in the Immediate window it still gives me the No value given... error

Sub RunRepository()
Dim Con As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim AccessFile As String
Dim TargetRange As Range
Dim Cmd As ADODB.Command
Dim StrSQL As String

Application.ScreenUpdating = False
AccessFile = ("N:\Referral Management (RAOC)\Internal\@DeptCommon\MorningRpt\MorningRpt.accdb")
On Error Resume Next
Set Con = New ADODB.Connection
If Err.Number <> 0 Then
  MsgBox ("Connection was not created")
  Exit Sub
End If
On Error GoTo 0

With Con
  .Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
End With
Set Cmd = CreateObject("ADODB.Command")
With Cmd
  .ActiveConnection = Con
    .CommandType = adCmdStoredProc
      .CommandText = "QryFx3"
    .Parameters.Append .CreateParameter("DateInput", adDate, adParamInput, , Sheets("DataEntry").Range("D5").Value)
  Set Rs = .Execute()
End With
Set Rs = New ADODB.Recordset
If Err.Number <> 0 Then
  Set Rs = Nothing
    Set Con = Nothing
    MsgBox ("Recordset was not created")
  Exit Sub
End If
On Error GoTo 0

Dim DateInput As Range
DateInput = Sheets("DataEntry").Range("D5")

StrSQL = "SELECT [TblInvCOB].COBDate AS COBDate, " & _
          "(Round(([TblInvCOB].[104_FxdUrg]+[TblInvCOB].[105_FxdRout])*0.6)) AS [23_RefFaxBacks], " & _
          "([TblInvCOB].[103_FxdEDI]+[TblInvCOB].[104_FxdUrg]+[TblInvCOB].[105_FxdRout])-[23_RefFaxBacks] AS [24_AuthFaxBacks], " & _
          "[TblInvCOB].[102_ReturnedMail] AS [25_ReturnedMail] " & _
          "FROM TblInvCOB " & _
          "WHERE(([TblInvCOB].COBDate) = #4/30/2018#);"

Rs.Open StrSQL, Con
            
'Check if the recordet is empty.
    If Rs.EOF And Rs.BOF Then
            'Close the recordet and the connection if empty.
        Rs.Close
        Con.Close
            'Release the objects.
        Set Rs = Nothing
        Set Con = Nothing
            'Enable screen.
        Application.ScreenUpdating = True
           
 'In case of an empty recordset display an error.
        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
    End If
Sheets("Repository").Range("A2").CopyFromRecordset Rs
Rs.Close
Con.Close
End Sub

 

[xenou]

This looks like a fundamental error:

With Con
  .Open "Provider = Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
End With
Set Cmd = CreateObject("ADODB.Command")
With Cmd
  .ActiveConnection = Con
    .CommandType = adCmdStoredProc
      .CommandText = "QryFx3"
    .Parameters.Append .CreateParameter("DateInput", adDate, adParamInput, , Sheets("DataEntry").Range("D5").Value)
[B][COLOR="#FF0000"]  Set Rs = .Execute()[/COLOR][/B]
End With
[B][COLOR="#FF0000"]Set Rs = New ADODB.Recordset[/COLOR][/B]
If Err.Number <> 0 Then
  Set Rs = Nothing
    Set Con = Nothing
    MsgBox ("Recordset was not created")
  Exit Sub
End If
On Error GoTo 0

In short you are creating the recordset, executing the query, and then destroying the recordset by creating a new one before you have done anything with it. After you run RS.Execute() you should have the data you need in that recordset. Your next step would be to output the data with your statement: Sheets("Repository").Range("A2").CopyFromRecordset Rs

Don't forget that the command object can be used to return recordsets too.

 

[RunTime91]

Xenou - Thank You!!!!

I think sometimes we become so immersed in solving the problem that we fail to see the solution is right in front of us.

Thanks for being a patient with me on this one...

I have learned a great deal from this experience.