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.

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

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

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.

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

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