Access Queries from Excel Sometimes Returning Blanks

jce108

New Member
Joined
Nov 25, 2011
Messages
4
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:

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 Sub

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
 

Some videos you may like

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

jce108

New Member
Joined
Nov 25, 2011
Messages
4
I have figured out what the issue is.

It appears that one of the linked table in access is not updating since I eliminated all the other variables and I am getting the same result now.

Is there a way to refresh linked access tables from excel?
 

Watch MrExcel Video

Forum statistics

Threads
1,127,620
Messages
5,625,910
Members
416,141
Latest member
Bartek9q

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
Top