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.
Thanks in advance.
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.
Code:
'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.