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...
Many thanks,
Andy
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