More effiecent way of comparing data (1 Viewer)

[jasn_78]

Ok I have a form "frmCOMPARISON" that allows the user to enter various options to report on sales for a date range this is then stored in a seperate query for each period that is set.

After this I then run a query to combine all periods into 1 query so i can export to an excel spreadsheet and a graph.

Now this works fine it just is really slow and i can see its probably not the best way of doing this but as i am still learning i wasn't sure how else to do it.

After a bit of reading it seems that the best idea would be to store all my values for each period in an array then send this to excel for my graph.

However I am not too sure in the process involved in doing this so any ideas on an improved method would be great.

'The below code allows a user to choose various options off a form
'then repeats that form for up to 9 periods
'
'This is then exported to an excel spread sheet as a column graph
'where all periods are stored as day values using DateDiff()
'
'
'This code was created by Jason Smith for Tony Finch Retail Services (TFRS)
'and as such remains the propety of TFRS unless otherwise authorised
'
'contact jason.smith@tfrs.com.au
'______________________________________________________


Private Sub Form_Current()

Dim toDate As Date
Dim fromDate As Date

toDate = Format((Now() - 1), "dd/mm/yyyy")
fromDate = Format((Now() - 1), "dd/mm/yyyy")

Me.txtDATEFROM1 = toDate
Me.txtDATETO1 = fromDate

End Sub



Private Sub cmdNEXT_Click()

Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim stDocName As String
Dim stLinkCriteria As String
Dim sql As String
Dim valp As String
Dim qtyp As String
Dim DATEFROM As Date
Dim DATETO As Date
Dim sqlstr As String
Dim inttill As Integer
Dim intarea As Integer
Dim strstore As String

On Error GoTo COMPARISON_ERROR

Set db = CurrentDb()

sqlstr = ""

P = Right(Forms("frmCOMPARISON").Caption, 1)

' check to see if date from and to entered
' if no date entered exit procedure and focus on date text box

If Nz(Me.txtDATEFROM1, 0) = 0 Then
    MsgBox "YOU MUST CHOOSE A START DATE", , "ENTER A DATE"
    Me.txtDATEFROM1.SetFocus
    Exit Sub
ElseIf Nz(Me.txtDATETO1, 0) = 0 Then
    MsgBox "YOU MUST CHOOSE AN END DATE", , "ENTER A DATE"
    Me.txtDATETO1.SetFocus
    Exit Sub
End If

valp = "PERIOD" & P
DATETO = Format(Me.txtDATETO1, "mm/dd/yyyy")
DATEFROM = Format(Me.txtDATEFROM1, "mm/dd/yyyy")

    If Nz(Me!frmAREAFILTERS.Form.comboTILL, 0) <> 0 Then
        inttill = [Forms]![frmCOMPARISON]![frmAREAFILTERS].[Form]![comboTILL]
        sqlstr = sqlstr & "AND ((HTRXTBL.HTRX_TILL_NUMBER)= " & inttill & ")"
    Else
        If Nz(Me!frmAREAFILTERS.Form.comboAREA, 0) <> 0 Then
            intarea = [Forms]![frmCOMPARISON]![frmAREAFILTERS].[Form]![comboAREA]
            sqlstr = sqlstr & "AND ((HTRXTBL.HTRX_AREA_NUMBER)= " & intarea & ")"
        Else
            If Nz(Me!frmAREAFILTERS.Form.comboSTORE, 0) <> 0 Then
            strstore = [Forms]![frmCOMPARISON]![frmAREAFILTERS].[Form]![comboSTORE]
            sqlstr = sqlstr & "AND ((HTRXTBL.HTRX_SYSC_NUMBER) LIKE " & strstore & ")"
            End If
        End If
    End If

sql = "SELECT (DateDiff('d', " & "#" & DATEFROM & "#" & ",(HTRXTBL.HTRX_TRX_DATE))) AS DAY, " & _
        "(Round(Sum(HTRXTBL.HTRX_VALUE),2)) AS " & valp & " " & _
        "FROM ITEMTBL INNER JOIN HTRXTBL " & _
        "ON ITEMTBL.ITEM_NUMBER = HTRXTBL.HTRX_ITEM_NUMBER " & _
        "WHERE (HTRXTBL.HTRX_REC_TYPE= 'ITMSALE') " & _
        "AND ((HTRXTBL.HTRX_TRX_DATE) >= " & "#" & DATEFROM & "#" & ") " & _
        "AND ((HTRXTBL.HTRX_TRX_DATE) <= " & "#" & DATETO & "#" & ") " & _
        sqlstr & _
        "GROUP BY HTRXTBL.HTRX_TRX_DATE"
 
Set qdf = db.CreateQueryDef("qryCOMPARISON" & P)
 
'Create qrycomparison
qdf.sql = sql
DoCmd.OpenQuery "qryCOMPARISON" & P

DoCmd.Close


P = Right(Forms("frmCOMPARISON").Caption, 1) + 1
  
'RENAME CAPTION OF FORM FOR EACH NEW PERIOD
If P <= 9 Then
    Forms("frmCOMPARISON").Caption = "SALES COMPARISON PERIOD" & P
Else
    MsgBox "You have entered the maximum amount of periods", vbOKOnly
    GoTo COMPARISON_EXIT
End If
  
'Re-open comparison for next period

stDocName = "frmCOMPARISON"
DoCmd.OpenForm stDocName, , , stLinkCriteria

Call reset_filters

COMPARISON_EXIT:
    Exit Sub

COMPARISON_ERROR:
MsgBox "Error " & Err.Number & ": " & Err.DESCRIPTION, , "COMPARISON ERROR"
    Resume COMPARISON_EXIT
    
End Sub

Private Sub cmdREPORT_Click()
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim qrycount As Integer
Dim sqlselectday As String
Dim sqlselect As String
Dim sqlfrom As String
Dim sqlwhere As String
Dim strsql As String

sqlselect = ""
sqlselectday = ""
sqlfrom = ""
sqlwhere = ""

Set db = CurrentDb()

qrycount = 1
    
    For Each qdf In db.QueryDefs
    If qdf.Name = "qryCOMPARISON1" Then
        sqlselectday = "Select " & qdf.Name & ".day"
        sqlselect = ", " & qdf.Name & ".PERIOD" & qrycount
        sqlfrom = "FROM qryCOMPARISON1"
        sqlwhere = "WHERE "
    End If
    Next
    

qrycount = 2

Do Until qrycount = 10
    For Each qdf In db.QueryDefs
    If qdf.Name = "qryCOMPARISON" & qrycount Then
        sqlfrom = sqlfrom & ", " & qdf.Name
        sqlselect = sqlselect & ", " & qdf.Name & ".PERIOD" & qrycount
        sqlwhere = sqlwhere & "qryCOMPARISON1.DAY = " & qdf.Name & ".DAY AND "
    End If
    Next
qrycount = qrycount + 1
Loop
sqlwhere = Left(sqlwhere, Len(sqlwhere) - 4)
        
        strsql = sqlselectday & sqlselect & " " & sqlfrom & " " & sqlwhere
        
        MsgBox strsql
        
For Each qdf In db.QueryDefs
If qdf.Name = "qryCOMPTOTALS" Then
    qrycount = 11
    If qrycount = 11 Then
        db.QueryDefs.Delete "qryCOMPTOTALS"
    End If
End If
Next

Set qdf = db.CreateQueryDef("qryCOMPTOTALS")

qdf.sql = strsql

DoCmd.OpenQuery "qryCOMPTOTALS"
DoCmd.Close

Call excelquery("qryCOMPTOTALS")

End Sub


Private Sub cmdCLEARFILTERS_Click()

Dim db As DAO.Database

Set db = CurrentDb()

Call reset_filters

Me!frmAREAFILTERS.Form.comboSTORE = Null
Me!frmAREAFILTERS.Form.comboAREA = Null
Me!frmAREAFILTERS.Form.comboTILL = Null
Me!subfrmPLUFILTERS.Form.txtPLUFROM = Null
Me!subfrmPLUFILTERS.Form.txtPLUTO = Null

End Sub
Private Sub cmdEXIT_Click()
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim qrycount As Integer

Set db = CurrentDb()

qrycount = 1

Do Until qrycount = 10
    For Each qdf In db.QueryDefs
    If qdf.Name = "qryCOMPARISON" & qrycount Then
    db.QueryDefs.Delete "qryCOMPARISON" & qrycount
    End If
    Next
qrycount = qrycount + 1
Loop

Call reset_filters

DoCmd.Close

End Sub
Public Function excelquery(qryname As String)

Dim rstdata As ADODB.Recordset
Dim rstcount As ADODB.Recordset
Dim fld As ADODB.Field
Dim rng As Excel.Range
Dim objws As Excel.worksheet
Dim introwcount As Integer
Dim intcolcount As Integer
Dim qcount As Integer

'DoCmd.Hourglass True

Set rstdata = New ADODB.Recordset
rstdata.ActiveConnection = CurrentProject.Connection

Set rstcount = New ADODB.Recordset
rstcount.ActiveConnection = CurrentProject.Connection

If CreateRecordset(rstdata, rstcount, qryname) Then

    If CreateExcelObj() Then
        gobjExcel.Workbooks.Add
        
        Set objws = gobjExcel.ActiveSheet
        introwcount = 1
        intcolcount = 1
        
        For Each fld In rstdata.Fields
            If fld.Type <> adLongVarBinary Then
                objws.Cells(1, intcolcount).Value = fld.Name
                intcolcount = intcolcount + 1
            End If
        Next fld
        
        objws.Range("A2").CopyFromRecordset rstdata, 500
        
        With gobjExcel
            .Columns("A:C").Select
            .Columns("A:C").EntireColumn.AutoFit
            .Range("A1").Select
            .ActiveCell.CurrentRegion.Select
            Set rng = .Selection
            .Columns("b:c").Select
            .Selection.NumberFormat = "$#,##0.00"
            
            .ActiveSheet.ChartObjects.Add(135.75, 14.25, 607.75, 301).Select
            
            .ActiveChart.ChartWizard Source:=.Range(rng.address), _
                gallery:=xlColumn, _
                Format:=6, PlotBy:=xlColumns, categorylabels:=1, serieslabels _
                :=1, HasLegend:=1, Title:="SALES COMPARISON REPORT", categorytitle _
                :="DAYS", valuetitle:="$ AMOUNT", extratitle:=""
            .Visible = True
        End With
        Else
        MsgBox "Excel Could not load"
        
    End If
    Else
    MsgBox "too many records to send"
    
End If

' DoCmd.Hourglass False

Set rng = Nothing
Set objws = Nothing
'gobjExcel.Quit
Set gobjExcel = Nothing

'gobjExcel = Nothing


End Function

Function CreateRecordset(rstdata As ADODB.Recordset, _
    rstcount As ADODB.Recordset, _
    strTableName As String)
'    On Error GoTo CreateRecordset_Err
    'Create recordset that contains count of records in query
    rstcount.Open "Select Count(*) As NumRecords from " & strTableName
    'If more than 500 records in query result, return false
    'Otherwise, create recordset from query
    If rstcount!NumRecords > 500 Then
        CreateRecordset = False
    Else
        rstdata.Open strTableName
        CreateRecordset = True
    End If
    
CreateRecordset_Exit:
    Set rstcount = Nothing
    Exit Function
    
CreateRecordset_Err:
    MsgBox "Error # " & Err.Number & ": " & Err.DESCRIPTION, , "RECORDSET ERROR"
    Resume CreateRecordset_Exit
End Function

Function CreateExcelObj() As Boolean
'    On Error GoTo CreateExcelObj_Err
    CreateExcelObj = False
    'Attempt to Launch Excel
    Set gobjExcel = New Excel.Application
    CreateExcelObj = True
    
CreateExcelObj_Exit:
    Exit Function
    
CreateExcelObj_Err:
    MsgBox "Couldn't Launch Excel!!", vbCritical, "Warning!!"
    CreateExcelObj = False
    Resume CreateExcelObj_Exit
End Function

Sub CloseExcel()
    
    If Not gobjExcel Is Nothing Then
        gobjExcel.DisplayAlerts = False
        gobjExcel.Quit
    End If
    
CloseExcel_Exit:
    Set gobjExcel = Nothing
    Exit Sub
    
CloseExcel_Err:
    MsgBox "Error # " & Err.Number & ": " & Err.DESCRIPTION
    Resume CloseExcel_Exit
End Sub

Thanks in advance.

 

[JohnLee]

Hi,

Why don't you use access's ability to create charts in the reports section. That way you haven't got to export to an excel file.

John

 

[jasn_78]

John the reason I didnt do it in access is i just dont think it looks as good. But if you can show me how to make it look more presentable that would work

 

[jasn_78]

also the excel part isnt the problem that is working fine and quickly the problem occurs speed wise running the 2nd query to combine all the totals.

 

[JohnLee]

Hi,

Well once you've used the wizard to create the general chart, what you can do is, go in to the design mode and make adjustments using the various features in that view to get to what you would like. Yes, it does take a bit of time and fine tuning etc, so perseverance is what is needed here, but once you've got what you want, it's there for as long as you want it and it's all in one application.

John

 

[jasn_78]

Hey john thanks for ur advice i will look at that but i have tested my code and the exporting to excel is the fast part like 5 secs tops the query parts can take up to 5 minutes which is my problem