Running SQL Queries in VBA

AndrewKent

AndrewKent

Well-known Member
Joined
Jul 26, 2006
Messages
889
Hi,

I'm having a bit on an issue. I have written many macros that will take data from a ".mdb" file using a query. This time however my query appears to be too long for VBA. Can anyone tell me what I am doing wrong? This is the code I am working on below...

Code: 
Option Explicit

Sub ExtractLeagueTableSupportReport()

'   =============================================================================================
'   This routine will extract data from the Activity Report table within the Sales Database
'   based on a date range.
'   =============================================================================================
    
    Dim VersionName As String
    Dim LastRow As Integer
    Dim ActiveRow As Integer
    Dim BancTelServer As String
    Dim DBName As String
    Dim DBLocation As String
    Dim FilePath As String
    Dim DBRecordSet As ADODB.Recordset
    Dim DBConnection As ADODB.Connection
    Dim ReferralID As String
    Dim Query As String
    Dim StartWeek As Integer
    Dim EndWeek As Integer
    Dim Query1 As String
    Dim Query2 As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set DBConnection = New ADODB.Connection
    VersionName = Worksheets("File Locations").Range("FL_VersionName").Value
    BancTelServer = Worksheets("File Locations").Range("FL_BancTel_Server").Value
    DBName = Worksheets("File Locations").Range("FL_SalesDatabase_File").Value
    DBLocation = Worksheets("File Locations").Range("FL_SalesDatabase_Location").Value
    FilePath = BancTelServer & DBLocation & DBName
    StartWeek = Worksheets("Date Matrix").Range("N19").Value
    EndWeek = Worksheets("Date Matrix").Range("N21").Value
    Query1 = Worksheets("Matrix").Range("Matrix_Query1").Value
    Query2 = Worksheets("Matrix").Range("Matrix_Query2").Value

    With Worksheets("League Table Support Report")
        .Select
        .Range("B18:Y" & Range("B65536").End(xlUp).Offset(2, 0).Row & "").Delete Shift:=xlUp
        .Range("B17:Y17").ClearContents
        .Range("A1").Select
    End With

    With DBConnection
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open FilePath
    End With
    
    Query = "" & Query1 & ""
    Query = "SELECT tblData_ActivityReport.ActvityReport_ContractCode, tblData_Claimed.Claimed_Referral_ID, tblData_Claimed.Claimed_Connect_ID, tblData_ActivityReport.ActvityReport_IntroducerName, tblData_Claimed.Claimed_Consultant, Null AS Consultant_Team_Leader, Null AS Consultant_CSM, tblData_Claimed.Claimed_Support_CSR, Null AS Support_Team_Leader, Null AS Support_CSM, tblData_ActivityReport.ActvityReport_CustomerName, tblData_ActivityReport.ActvityReport_EventType, tblDefinition_ProductCode.ProductCode_Type, tblData_ActivityReport.ActvityReport_EventDate, tblData_ActivityReport.ActvityReport_WeekNo, Null AS Quarter, tblData_Claimed.Claimed_Credit AS Claimed, IIf([ActvityReport_EventType]='Application',[ActvityReport_FPD_Credit],Null) AS Application, IIf([ActvityReport_EventType]='Pipeline',[ActvityReport_FPD_Credit],Null) AS Pipeline, IIf([ActvityReport_EventType]='Issued',[ActvityReport_FPD_Credit],Null)" _
             Issued, IIf([ActvityReport_EventType]='Reinstatement',[ActvityReport_FPD_Credit],Null) AS Reinstatement, IIf([ActvityReport_EventType]='Lapse',[ActvityReport_FPD_Credit],Null) AS Lapse, IIf([ActvityReport_EventType]='Cool-Off',[ActvityReport_FPD_Credit],Null) AS [Cool-Off], IIf([ActvityReport_EventType]='NTU',[ActvityReport_FPD_Credit],Null) AS [Not Taken Up] _
FRM tblDefinition_ProductCode INNER JOIN ((tblData_Claimed RIGHT JOIN tblData_Codes ON tblData_Claimed.Claimed_Referral_ID = tblData_Codes.Claimed_Referral_ID) _
RIGHT JOIN tblData_ActivityReport ON tblData_Codes.ActivityReport_ContractCode = tblData_ActivityReport.ActvityReport_ContractCode) ON tblDefinition_ProductCode.ActvityReport_ProductCode = tblData_ActivityReport.ActvityReport_ProductCode WHERE (((tblData_ActivityReport.ActvityReport_WeekNo) >= " & WeekStart & " And (tblData_ActivityReport.ActvityReport_WeekNo) <= " & WeekEnd & ")) ORDER BY tblData_ActivityReport.ActvityReport_ContractCode, tblData_ActivityReport.ActvityReport_EventType, tblData_ActivityReport.ActvityReport_EventDate;"
    Set DBRecordSet = New ADODB.Recordset
    DBRecordSet.CursorLocation = adUseServer
    DBRecordSet.Open Source:=Query, ActiveConnection:=DBConnection, CursorType:=adOpenForwardOnly, LockType:=adLockOptimistic, Options:=adCmdText
    
    Worksheets("Activity Report Extract").Range("B17").CopyFromRecordset DBRecordSet
    
    DBRecordSet.Close
    Set DBRecordSet = Nothing
    
    Query = "" & Query2 & ""
    Set DBRecordSet = New ADODB.Recordset
    DBRecordSet.CursorLocation = adUseServer
    DBRecordSet.Open Source:=Query, ActiveConnection:=DBConnection, CursorType:=adOpenForwardOnly, LockType:=adLockOptimistic, Options:=adCmdText
    
    Worksheets("Activity Report Extract").Range("B" & Range("B65536").End(xlUp).Offset(1, 0).Row & "").CopyFromRecordset DBRecordSet
    
    DBRecordSet.Close
    DBConnection.Close
    Set DBRecordSet = Nothing
    Set DBConnection = Nothing
    
    With Worksheets("League Table Support Report")
        .Select
        If Range("B65536").End(xlUp).Row = 6 Then
        
        Else
            .Range("B17:Y17").Copy
            .Range("B17:Y" & Range("B65536").End(xlUp).Row & "").PasteSpecial xlPasteFormats
            ' Enter cleanup routines here
        End If
        .Range("A1").Select
    End With

    Worksheets("Index").Select
    Range("A1").Select
    
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Many thanks,

Andy
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
After looking on the 'net it seems that VBA doesn't like the query to be split over multiple lines. does anyone know how to do this?
 
Upvote 0
Still working on it but this seems fine now;


Code: 
Sub ExtractLeagueTableSupportReport()

'   =============================================================================================
'   This routine will extract data from the Activity Report table within the Sales Database
'   based on a date range.
'   =============================================================================================
    
    Dim VersionName As String
    Dim LastRow As Integer
    Dim ActiveRow As Integer
    Dim BancTelServer As String
    Dim DBName As String
    Dim DBLocation As String
    Dim FilePath As String
    Dim DBRecordSet As ADODB.Recordset
    Dim DBConnection As ADODB.Connection
    Dim ReferralID As String
    Dim Query As String
    Dim StartWeek As Integer
    Dim EndWeek As Integer

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set DBConnection = New ADODB.Connection
    VersionName = Worksheets("File Locations").Range("FL_VersionName").Value
    BancTelServer = Worksheets("File Locations").Range("FL_BancTel_Server").Value
    DBName = Worksheets("File Locations").Range("FL_SalesDatabase_File").Value
    DBLocation = Worksheets("File Locations").Range("FL_SalesDatabase_Location").Value
    FilePath = BancTelServer & DBLocation & DBName
    StartWeek = Worksheets("Date Matrix").Range("N19").Value
    EndWeek = Worksheets("Date Matrix").Range("N21").Value

    With Worksheets("League Table Support Report")
        .Select
        .Range("B18:Y" & Range("B65536").End(xlUp).Offset(2, 0).Row & "").Delete Shift:=xlUp
        .Range("B17:Y17").ClearContents
        .Range("A1").Select
    End With

    With DBConnection
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open FilePath
    End With

    Query = "SELECT tblData_ActivityReport.ActvityReport_ContractCode" _
    & ", tblData_Claimed.Claimed_Referral_ID, tblData_Claimed.Claimed_Connect_ID, tblData_ActivityReport.ActvityReport_IntroducerName, " _
    & "tblData_Claimed.Claimed_Consultant, Null AS Consultant_Team_Leader, Null AS Consultant_CSM, tblData_Claimed.Claimed_Support_CSR, Null " _
    & "AS Support_Team_Leader, Null AS Support_CSM, tblData_ActivityReport.ActvityReport_CustomerName, tblData_ActivityReport.ActvityReport_EventType, " _
    & "tblDefinition_ProductCode.ProductCode_Type, tblData_ActivityReport.ActvityReport_EventDate, tblData_ActivityReport.ActvityReport_WeekNo, Null AS Quarter, " _
    & "tblData_Claimed.Claimed_Credit AS Claimed, IIf([ActvityReport_EventType]='Application',[ActvityReport_FPD_Credit],Null) AS Application, " _
    & "IIf([ActvityReport_EventType]='Pipeline',[ActvityReport_FPD_Credit],Null) AS Pipeline, IIf([ActvityReport_EventType]='Issued'," _
    & "[ActvityReport_FPD_Credit],Null) AS Issued, IIf([ActvityReport_EventType]='Reinstatement',[ActvityReport_FPD_Credit],Null) AS Reinstatement, IIf([ActvityReport_EventType]='Lapse'," _
    & "[ActvityReport_FPD_Credit],Null) AS Lapse, IIf([ActvityReport_EventType]='Cool-Off',[ActvityReport_FPD_Credit],Null) AS [Cool-Off], " _
    & "IIf([ActvityReport_EventType]='NTU',[ActvityReport_FPD_Credit],Null) AS [Not Taken Up] FROM tblDefinition_ProductCode INNER JOIN ((tblData_Claimed RIGHT JOIN tblData_Codes " _
    & "ON tblData_Claimed.Claimed_Referral_ID = tblData_Codes.Claimed_Referral_ID) RIGHT JOIN tblData_ActivityReport ON tblData_Codes.ActivityReport_ContractCode = " _
    & "tblData_ActivityReport.ActvityReport_ContractCode) ON tblDefinition_ProductCode.ActvityReport_ProductCode = tblData_ActivityReport.ActvityReport_ProductCode " _
    & "WHERE (((tblData_ActivityReport.ActvityReport_WeekNo) >= 1 And (tblData_ActivityReport.ActvityReport_WeekNo) <= 10)) ORDER BY tblData_ActivityReport.ActvityReport_ContractCode, " _
    & "tblData_ActivityReport.ActvityReport_EventType, tblData_ActivityReport.ActvityReport_EventDate;"
    
    Set DBRecordSet = New ADODB.Recordset
    DBRecordSet.CursorLocation = adUseServer
    DBRecordSet.Open Source:=Query, ActiveConnection:=DBConnection, CursorType:=adOpenForwardOnly, LockType:=adLockOptimistic, Options:=adCmdText
    
    Worksheets("Activity Report Extract").Range("B17").CopyFromRecordset DBRecordSet
    
'    DBRecordSet.Close
'    Set DBRecordSet = Nothing
'
'    Query = "" & Query2 & ""
'    Set DBRecordSet = New ADODB.Recordset
'    DBRecordSet.CursorLocation = adUseServer
'    DBRecordSet.Open Source:=Query, ActiveConnection:=DBConnection, CursorType:=adOpenForwardOnly, LockType:=adLockOptimistic, Options:=adCmdText
'
'    Worksheets("Activity Report Extract").Range("B" & Range("B65536").End(xlUp).Offset(1, 0).Row & "").CopyFromRecordset DBRecordSet
    
    DBRecordSet.Close
    DBConnection.Close
    Set DBRecordSet = Nothing
    Set DBConnection = Nothing
    
    With Worksheets("League Table Support Report")
        .Select
        If Range("B65536").End(xlUp).Row = 6 Then
        
        Else
            .Range("B17:Y17").Copy
            .Range("B17:Y" & Range("B65536").End(xlUp).Offset(1, 0).Row & "").PasteSpecial xlPasteFormats
            ' Enter cleanup routines here
        End If
        .Range("A1").Select
    End With

    Worksheets("Index").Select
    Range("A1").Select
    
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Andy
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
SQL Query Failing with Run-time error '3704: Operation is not allowed when the object is closed.
Replies
1
Views
552
gedkins
G
M
  • Question
vba help - wild card in SQL Query
Replies
2
Views
1K
Mallesh23
M
M
  • Question
vba help - sql query not working for headers which begin with numbers.
Replies
4
Views
1K
Mallesh23
M
K
  • Question
Running long SQL query using VBA
Replies
4
Views
2K
kirtesh250187
K
J
  • Question
Strange behaviour in VBA
Replies
1
Views
469
RoryA
RoryA

Forum statistics

Threads
1,214,414
Messages
6,119,373
Members
448,888
Latest member
Arle8907

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top