Hi everyone,
This my first post, been lurking for some time and I should say thank you very much, you are all much smarter than I am.
So now on to the question:
I am running an access query in our access database that query's the sales of several items for several accounts, within a specific period of time (determined by starting date and end date) for testing purposes and because i'm frustrated i have set this as 01/01/2010 - 31/12/2011.
it runs this query twice (usually the dates are for one period and then another) and then totals the sales for comparison purposes.
The unique account numbers are put into one sheet and the unique item numbers another sheet.
The access query then runs based on these sheets.
The problem is:
When I loop the code multiple times there are some that return 0(blank access return). However if i run this specific instance by itself it returns the correct results.
Also if i run it multiple times and then pause the code right before and after it runs the query and instead manually enter the query into excel it returns the correct information as well.
I will post my code bellow:
The date code can almost completely be ignored since it's not really being called again during testing purposes
Also I am sure the item and cust codes are correctly being place in their respective sheets I know it's a little hard to know just looking at code.
Thanks
If anyone can help that would be much appreciate I've been banging my head against the wall for some time.
Even if you just post that you don't know what the problem is it will make me feel at least a little better.
Thanks all
James
This my first post, been lurking for some time and I should say thank you very much, you are all much smarter than I am.
So now on to the question:
I am running an access query in our access database that query's the sales of several items for several accounts, within a specific period of time (determined by starting date and end date) for testing purposes and because i'm frustrated i have set this as 01/01/2010 - 31/12/2011.
it runs this query twice (usually the dates are for one period and then another) and then totals the sales for comparison purposes.
The unique account numbers are put into one sheet and the unique item numbers another sheet.
The access query then runs based on these sheets.
The problem is:
When I loop the code multiple times there are some that return 0(blank access return). However if i run this specific instance by itself it returns the correct results.
Also if i run it multiple times and then pause the code right before and after it runs the query and instead manually enter the query into excel it returns the correct information as well.
I will post my code bellow:
Code:
Sub MultipleQuery()
Dim RefNum As Double
Dim Count As Long
Dim CustNum As Long
Dim ItemNum As String
Dim CatNum As Long
Dim PromoDate1 As Date
Dim PromoDate2 As Date
Dim BuyInDate1 As Date
Dim BuyInDate2 As Date
Dim UseDate1 As Date
Dim UseDate2 As Date
Dim PromoType As String
Dim x As Long
Dim TotalRepCost As Long
Dim TotalSupplierCost As Long
Dim MCB As Long
Dim TotalSupplyCost As Long
Dim DemoPerson As String
Dim BottomRng As Range
Dim CustName As String
Dim BuyInCheck As Boolean
Dim OkCancel As Long
Dim DivideBy As Long
Dim PromoLength As Long
Dim Highlight As Range
Dim TotalPromoSales1 As Currency
Dim TotalPromoSales2 As Currency
Dim TotalPromoCost1 As Currency
Dim TotalPromoCost2 As Currency
Dim TotalPromoCount1 As Currency
Dim TotalPromoCount2 As Currency
Dim QueryCountTotal As Long
Dim QueryCount As Long
Dim RepID As String
Dim RepName As String
Dim PctDone As Currency
Dim ItemCombine As String
Dim CustCombine As String
Dim xLoopCount As Long
Dim y As Long
'Create Resutls Page
On Error Resume Next
Application.DisplayAlerts = False
Sheets("MultipleResults").Delete
Sheets.Add.Name = "MultipleResults"
Sheets("MultipleResults").Range("a1").Value = "Ref#"
Sheets("MultipleResults").Range("b1").Value = "Customer#"
Sheets("MultipleResults").Range("c1").Value = "City"
Sheets("MultipleResults").Range("d1").Value = "Province"
Sheets("MultipleResults").Range("e1").Value = "Customer Name"
Sheets("MultipleResults").Range("f1").Value = "Category"
Sheets("MultipleResults").Range("g1").Value = "Items"
Sheets("MultipleResults").Range("h1").Value = "Rep ID"
Sheets("MultipleResults").Range("i1").Value = "Rep Name"
Sheets("MultipleResults").Range("j1").Value = "Buyin Date 1"
Sheets("MultipleResults").Range("k1").Value = "Buyin Date 2"
Sheets("MultipleResults").Range("l1").Value = "Sales Baseline"
Sheets("MultipleResults").Range("m1").Value = "Cost Baseline"
Sheets("MultipleResults").Range("n1").Value = "Quantity Baseline"
Sheets("MultipleResults").Range("o1").Value = "Sales Buy In"
Sheets("MultipleResults").Range("p1").Value = "Cost Buy In"
Sheets("MultipleResults").Range("q1").Value = "Quantity Buy In"
Sheets("MultipleResults").Range("r1").Value = "Our Cost"
Sheets("MultipleResults").Range("s1").Value = "Vendor Cost"
Sheets("MultipleResults").Range("t1").Value = "Suplies Cost"
Sheets("MultipleResults").Range("u1").Value = "Total Cost"
Sheets("MultipleResults").Range("v1").Value = "ROI"
Sheets("MultipleResults").Range("w1").Value = "PromoType"
Application.DisplayAlerts = True
On Error GoTo 0
Sheets("Multiple Backend").Activate
QueryCount = 0
QueryCountTotal = Application.WorksheetFunction.CountA(Range("A:A"))
'Takes Info From the backend and queries it
Application.ScreenUpdating = True
'Sets Basic Variables
'Load Bar Code
PctDone = QueryCount / QueryCountTotal
With massloading
.FrameProgress.Caption = Format(PctDone, "0%")
.Label1.Caption = QueryCount & "/" & QueryCountTotal & " Queries Completed"
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
With massloading
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
' The DoEvents statement is responsible for the form updating
DoEvents
Do Until (QueryCount + 1) > QueryCountTotal
'Position Correctly
Sheets("Multiple Backend").Activate
Range("a1").Select
i = 0
Do Until i = QueryCount + 1
ActiveCell.End(xlDown).Select
i = i + 1
Loop
RefNum = ActiveCell.Offset(-1, 1).Value
RepID = ActiveCell.Offset(0, 4).Value
RepName = ActiveCell.Offset(0, 25).Value
Set BottomRng = ActiveCell
Count = Application.WorksheetFunction.CountIf(Range("B:B"), RefNum)
CustName = ActiveCell.Offset(0, 1).Value
TotalRepCost = ActiveCell.Offset(0, 9).Value
TotalSupplierCost = ActiveCell.Offset(0, 10).Value
MCB = ActiveCell.Offset(0, 11).Value
PromoDate1 = ActiveCell.Offset(-1, 12).Value
PromoDate2 = ActiveCell.Offset(-1, 13).Value
BuyInDate1 = ActiveCell.Offset(-1, 14).Value
BuyInDate2 = ActiveCell.Offset(-1, 15).Value
DemoPerson = ActiveCell.Offset(-1, 16).Value
PromoType = ActiveCell.Offset(-1, 8).Value
TotalSupplyCost = ActiveCell.Offset(0, 17).Value
CatNum = ActiveCell.Offset(0, 2).Value
If BuyInDate1 = "12:00:00 AM" Or BuyInDate2 = "12:00:00 AM" Then
BuyInCheck = False
Else
BuyInCheck = True
End If
'Check Defaults Handle Missing Data
If PromoType = "Promo" And BuyInCheck = "False" Then
BuyInDate1 = DateAdd("d", -9, PromoDate1)
BuyInDate2 = PromoDate1
'OkCancel = MsgBox("No Buy in Date Specified! For Ref#: " & RefNum & "Defaulted to 9 days before promo", vbOKCancel)
'If OkCancel = vbCancel Then
' Exit Sub
'End If
End If
If PromoType = "Demo" And BuyInCheck = False Then
BuyInDate1 = DateAdd("d", -9, PromoDate1)
BuyInDate2 = PromoDate1
End If
If PromoType = "Repbox" Or PromoType = "Sample" Then
MsgBox "Sample and Repbox Support Note Yet Included", vbCritical
Sheets("main").Activate
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Multiple Backend").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Exit Sub
End If
If PromoType = "Demo" And DateDiff("d", PromoDate1, PromoDate2) < 10 Then
PromoDate2 = DateAdd("d", 30, PromoDate1)
End If
If PromoType = "Promo" And PromoDate1 = "12:00:00 AM" And BuyInCheck = True Then
Exit Sub
Else
PromoDate1 = DateAdd("d", 0, BuyInDate2)
End If
If PromoType = "Promo" And PromoDate2 = "12:00:00 AM" Then
PromoDate2 = DateAdd("d", 30, PromoDate1)
End If
PromoLength = DateDiff("d", BuyInDate1, BuyInDate2)
'End Checks and Handling
'Move All Unique Customer#'s to Correct Sheet that Acess can Pull From
Sheets("Multiple Backend").Activate
Sheets("CustNumList").Cells.Clear
y = 0
x = 0
Do Until IsEmpty(ActiveCell.Offset(0 - 1 - x, 2))
CustNum = ActiveCell.Offset(0 - 1 - x, 2).Value
If Application.WorksheetFunction.CountIf(Sheets("CustNumList").Range("A:A"), CustNum) = 0 Then
Sheets("CustNumList").Range("a1").Offset(y, 0).Value = CustNum
y = y + 1
End If
x = x + 1
Loop
x = 0
y = 0
'Item Num Move
y = 0
x = 0
Sheets("Multiple Backend").Activate
Sheets("ItemNumList").Cells.Clear
Do Until IsEmpty(ActiveCell.Offset(0 - 1 - x, 21))
ItemNum = ActiveCell.Offset(0 - 1 - x, 21).Value
If Application.WorksheetFunction.CountIf(Sheets("ItemNumList").Range("A:A"), ItemNum) = 0 Then
Sheets("ItemNumList").Range("a1").Offset(y, 0).Value = ItemNum
y = y + 1
End If
x = x + 1
Sheets("Multiple Backend").Activate
Loop
x = 0
y = 0
'Move All Unique Item#'s to Correct Sheet for easy access
'Sheets("ItemNumList").Cells.Clear
'Sheets("ItemNumList").Range("A1").Value = "Item Numbers"
'Do While x < Count
' ItemNum = Sheets("Multiple Backend").Range("v2").Offset(x, 0).Value
' Sheets("ItemNumList").Activate
' If Application.WorksheetFunction.CountIf(ActiveSheet.Range("A:A"), ItemNum) = 0 Then
' ActiveSheet.Range("A65536").Select
' ActiveCell.End(xlUp).Select
' ActiveCell.Offset(1, 0).Value = ItemNum
' End If
' x = x + 1
'Loop
'x = 0
Do While xLoopCount < 2
'Query Ready First time
Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset
'Create Results Sheet
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Interm Results").Delete
Application.DisplayAlerts = True
Sheets.Add.Name = "Interm Results"
On Error GoTo 0
'Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase _
("x:\PromoReporting.mdb")
Set MyQueryDef = MyDatabase.QueryDefs("James ITEMS/ACCOUNTS sold Date range Specific")
'Define the Parameters
If xLoopCount = 0 Then
'Sets Date as 6 months before to promo date
UseDate1 = DateAdd("m", -6, BuyInDate1)
UseDate2 = DateAdd("m", 0, BuyInDate1)
DivideBy = DateDiff("d", UseDate1, UseDate2)
End If
If xLoopCount = 1 Then
UseDate1 = BuyInDate1
UseDate2 = BuyInDate2
DivideBy = DateDiff("d", UseDate1, UseDate2)
End If
With MyQueryDef
'.Parameters("[Enter Category Number]") = CatNum
.Parameters("[Enter Starting Date]") = "01/01/2010"
.Parameters("[Enter Ending Date]") = "31/12/2011"
End With
'Starts the query
Set MyRecordset = MyQueryDef.OpenRecordset
'Copy the recordset to Excel
Sheets("Interm Results").Activate
Sheets("interm results").Range("a2").CopyFromRecordset MyRecordset
'Add column heading names to the spreadsheet based on the most recent query (important to have all the columns always be the same
For i = 1 To MyRecordset.Fields.Count
ActiveSheet.Range("a1").Offset(0, i - 1).Value = MyRecordset.Fields(i - 1).Name
Next i
Sheets("Interm Results").Activate
'Modify results to fit time period
Sheets("Interm Results").Activate
Range("E2").Select
i = 0
Do Until IsEmpty(ActiveCell.Offset(i, 0))
'ActiveCell.Offset(i, 0).Value = ActiveCell.Offset(i, 0).Value / DivideBy * PromoLength
'ActiveCell.Offset(i, 1).Value = Round(ActiveCell.Offset(i, 1).Value / DivideBy * PromoLength, 1)
' ActiveCell.Offset(i, 3).Value = ActiveCell.Offset(i, 3).Value / DivideBy * PromoLength
i = i + 1
Loop
i = 0
Sheets("Interm Results").Activate
Range("a2").Select
'Customer Number Merge (Uses RepID)
If xLoopCount = 0 Then
Sheets("Interm Results").Activate
Range("a2").Select
TotalPromoSales1 = 0
TotalPromoCount1 = 0
TotalPromoCost1 = 0
Do Until IsEmpty(ActiveCell)
TotalPromoSales1 = TotalPromoSales1 + ActiveCell.Offset(0, 4).Value
TotalPromoCount1 = TotalPromoCount1 + ActiveCell.Offset(0, 5).Value
TotalPromoCost1 = TotalPromoCost1 + ActiveCell.Offset(0, 7).Value
ActiveCell.Offset(1, 0).Select
Loop
End If
If xLoopCount = 1 Then
TotalPromoSales2 = 0
TotalPromoCount2 = 0
TotalPromoCost2 = 0
Sheets("Interm Results").Activate
Range("a2").Select
Do Until IsEmpty(ActiveCell)
TotalPromoSales2 = TotalPromoSales2 + ActiveCell.Offset(0, 4).Value
TotalPromoCount2 = TotalPromoCount2 + ActiveCell.Offset(0, 5).Value
TotalPromoCost2 = TotalPromoCost2 + ActiveCell.Offset(0, 7).Value
ActiveCell.Offset(1, 0).Select
Loop
End If
xLoopCount = xLoopCount + 1
ItemCombine = ""
Sheets("ItemNumList").Activate
Range("a1").Select
ItemCombine = ActiveCell.Value
Do Until IsEmpty(ActiveCell.Offset(1, 0))
ItemCombine = ItemCombine & " | " & ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(1, 0).Select
Loop
'MsgBox ItemCombine
CustCombine = ""
Sheets("CustNumList").Activate
Range("a1").Select
CustCombine = ActiveCell.Value
Do Until IsEmpty(ActiveCell.Offset(1, 0))
CustCombine = CustCombine & " | " & ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(1, 0).Select
Loop
'MsgBox CustCombine
Loop
Sheets("MultipleResults").Range("a1").Offset(QueryCount + 1, 0).Value = RefNum
Sheets("MultipleResults").Range("b1").Offset(QueryCount + 1, 0).Value = CustNum
On Error Resume Next
If Len(CustNum) > 6 Then
Sheets("MultipleResults").Range("c1").Offset(QueryCount + 1, 0).Value = "Multiple Accounts"
Else
Sheets("MultipleResults").Range("c1").Offset(QueryCount + 1, 0).Value = Application.WorksheetFunction.VLookup(CustNum, Sheets("Customer List").Range("a:e"), 5, False)
End If
If Len(CustNum) > 6 Then
Sheets("MultipleResults").Range("d1").Offset(QueryCount + 1, 0).Value = "Multiple Accounts"
Else
Sheets("MultipleResults").Range("d1").Offset(QueryCount + 1, 0).Value = Application.WorksheetFunction.VLookup(CustNum, Sheets("Customer List").Range("a:f"), 6, False)
End If
On Error GoTo 0
Sheets("MultipleResults").Range("e1").Offset(QueryCount + 1, 0).Value = CustCombine
Sheets("MultipleResults").Range("f1").Offset(QueryCount + 1, 0).Value = CatNum
Sheets("MultipleResults").Range("g1").Offset(QueryCount + 1, 0).Value = ItemCombine
Sheets("MultipleResults").Range("h1").Offset(QueryCount + 1, 0).Value = RepID
Sheets("MultipleResults").Range("i1").Offset(QueryCount + 1, 0).Value = RepName
Sheets("MultipleResults").Range("j1").Offset(QueryCount + 1, 0).Value = BuyInDate1
Sheets("MultipleResults").Range("k1").Offset(QueryCount + 1, 0).Value = BuyInDate2
Sheets("MultipleResults").Range("l1").Offset(QueryCount + 1, 0).Value = TotalPromoSales1
Sheets("MultipleResults").Range("m1").Offset(QueryCount + 1, 0).Value = TotalPromoCost1
Sheets("MultipleResults").Range("n1").Offset(QueryCount + 1, 0).Value = TotalPromoCount1
Sheets("MultipleResults").Range("o1").Offset(QueryCount + 1, 0).Value = TotalPromoSales2
Sheets("MultipleResults").Range("p1").Offset(QueryCount + 1, 0).Value = TotalPromoCost2
Sheets("MultipleResults").Range("q1").Offset(QueryCount + 1, 0).Value = TotalPromoCount2
Sheets("MultipleResults").Range("r1").Offset(QueryCount + 1, 0).Value = TotalRepCost
Sheets("MultipleResults").Range("s1").Offset(QueryCount + 1, 0).Value = TotalSupplierCost
Sheets("MultipleResults").Range("t1").Offset(QueryCount + 1, 0).Value = TotalSupplyCost
Sheets("MultipleResults").Range("u1").Offset(QueryCount + 1, 0).Value = TotalRepCost + TotalSupplierCost + TotalSupplyCost
Sheets("MultipleResults").Range("v1").Offset(QueryCount + 1, 0).Value = "ROI"
Sheets("MultipleResults").Range("w1").Offset(QueryCount + 1, 0).Value = PromoType
QueryCount = QueryCount + 1
x = 0
i = 0
xLoopCount = 0
PctDone = QueryCount / QueryCountTotal
With massloading
.FrameProgress.Caption = Format(PctDone, "0%")
.Label1.Caption = QueryCount & "/" & QueryCountTotal & " Queries Completed"
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
With massloading
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
' The DoEvents statement is responsible for the form updating
DoEvents
Loop
Sheets("MultipleResults").Activate
Range("a1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = False
On Error Resume Next
'Sheets("Interm Results").Delete
'Sheets("Multiple Backend").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Application.ScreenUpdating = True
Unload massloading
Exit Sub
'Error Mask
Application.ScreenUpdating = False
Errormask:
Application.DisplayAlerts = False
On Error Resume Next
MsgBox "Critical Error Occured", vbCritical
Sheets("Interm Results").Delete
Sheets("Multiple Backend").Delete
End SubThe date code can almost completely be ignored since it's not really being called again during testing purposes
Also I am sure the item and cust codes are correctly being place in their respective sheets I know it's a little hard to know just looking at code.
Thanks
If anyone can help that would be much appreciate I've been banging my head against the wall for some time.
Even if you just post that you don't know what the problem is it will make me feel at least a little better.
Thanks all
James
