LOOP through the Main table RECORDS
LOOP through the Main table COLUMNS stopping at each "_Gross" column
calculate dblGross by adding values
NEXT COLUMN
NoJob = dblGross - Amount
Overhead_Gross = Overhead_Gross + NoJob
TotalGross = dblGross + NoJob
dblGross=0
NEXT RECORD
Option Compare Database
Option Explicit
Private Sub cmdOpenTable_Click()
DoCmd.OpenTable "ProfitByCustomer"
End Sub
Private Sub Form_Open(Cancel As Integer)
On Error GoTo Form_Open_err
100 lstCustomer.RowSource = ""
110 Call fncQODBCQuery("Select FullName from Customer where sublevel=0", True)
120 Call fncRunSQL("select * into tblCustomer_RL from qryTemp")
130 lstCustomer.RowSource = "select FullName from tblCustomer_RL"
Exit Sub
Form_Open_err:
Debug.Print "Form_Open", Erl, Err.Number, Err.Description
End Sub
Private Sub cmdCreateTable_Click()
On Error GoTo cmdCreateTable_Click_err
'*** Make Total Profit Report
100 Dim t As String, i As Integer
110 t = "ProfitByCustomer"
120 Call fncProfitTable(t, DateFrom, DateTo)
'*** add columns
130 Call fncAddField(t, "TotalGross", dbDouble, False)
140 Call fncAddField(t, "TotalNets", dbDouble, False)
'*** add overhead first so it comes before the customer data
150 Call PutGross("tblTemp", t, "Overhead")
160 Call fncAddField(t, "NoJob", dbDouble, False)
'*** iterate through customers
300 For i = 0 To lstCustomer.ListCount - 1
310 If lstCustomer.ItemData(i) <> "Overhead" Then
320 Call PutGross("tblTemp", t, lstCustomer.ItemData(i))
330 End If
340 Next i
'*** drop unnecessary Overhead columns
400 Call fncRunSQL("ALTER TABLE " & t & " DROP COLUMN [Overhead_OH]")
410 Call fncRunSQL("ALTER TABLE " & t & " DROP COLUMN [Overhead_Net]")
'*** perform calculations
500 Call PutTotals(t)
510 Call PutOverhead(t)
520 Call PutNet(t)
530 Call TotalNets(t)
'*** delete zero rows and drop NoJob column
540 Call fncDeleteRecord(t, "Amount", "0")
560 Call fncRunSQL("ALTER TABLE " & t & " DROP COLUMN [NoJob]")
57 DoCmd.OpenTable t
Exit Sub
cmdCreateTable_Click_err:
Debug.Print "cmdCreateTable_Click", Erl, Err.Number, Err.Description
End Sub
Private Sub PutGross(sTableFrom As String, sTableTo As String, sCustomer As String)
On Error GoTo PutGross_err
'*** create a viable Customer column by removing spaces, etc.
100 Dim sColumn As String
110 sColumn = fncColumn(sCustomer)
'*** import the data for this customer into a temporary table
120 Call fncProfitTable("tblTemp", DateFrom, DateTo, sCustomer)
'*** if this customer had no activity, don't add it
130 If Nz(DSum("[AMOUNT]", "tblTemp", "[DESCRIPTION]='NET INCOME'"), 0) = 0 Then Exit Sub
'*** add additional columns for this customer to the Main table
150 Call fncAddField(sTableTo, sColumn & "_Gross", dbDouble, False, 20)
160 Call fncAddField(sTableTo, sColumn & "_OH", dbDouble, False, 20)
170 Call fncAddField(sTableTo, sColumn & "_Net", dbDouble, False, 20)
'*** loop through the temporary table updating the Main table
'*** you may wish to do this using two recordsets instead of the Update Record method
'*** the two recordset method is faster, just more code lines
200 Dim db As DAO.Database, rs As DAO.Recordset
210 Set db = CurrentDb
220 Set rs = db.OpenRecordset(sTableFrom)
300 If rs.RecordCount > 0 Then
310 rs.MoveLast
320 rs.MoveFirst
330 Do While Not rs.EOF
340 Call fncRunSQL("Update " & sTableTo & _
" set " & sColumn & "_gross = " & rs("Amount").Value & _
" where Description='" & rs("Description") & "'")
350 rs.MoveNext
360 Loop
380 End If
390 rs.Close
400 Set rs = Nothing
410 Set db = Nothing
Exit Sub
PutGross_err:
Debug.Print "cmdCreateTable_Click", Erl, Err.Number, Err.Description
End Sub
Private Sub PutTotals(sTableName As String)
On Error GoTo PutTotals_err
'*** Step 1. Add all Cutomer_Gross + Overhead_Gross to get dblGross
' This amount will differ from Amount column if all expenses were not assigned a job or overhead
'*** Step 2. Subtract Amount from dblGross for the NoJob amount--expenses not assigned to jobs
'*** Step 3. Add the NoJob amount to the Overhead_Gross amount for the true Overhead amount
' This equals: Jobs amounts + Overhead Amount + Amounts not assigned to jobs
'*** Step 4. Add the NoJob amouns to the TotalGross amounts
' This is a double check column that should match the Amount column figures in the end
' It shows that jobs + overhead + no jobs = amounts from profit report by TotalOnly
100 Dim db As DAO.Database, rs As DAO.Recordset, i As Integer
110 Dim dblGross As Double, dblNoJob As Double
210 Set db = CurrentDb
220 Set rs = db.OpenRecordset(sTableName)
230 If rs.RecordCount > 0 Then
240 rs.MoveLast
250 rs.MoveFirst
300 Do While Not rs.EOF
310 For i = 0 To rs.Fields.Count - 1
320 If rs.Fields(i).Name Like "*gross*" Then
330 dblGross = dblGross + Nz(rs.Fields(i).Value, 0)
370 End If
380 Next i
400 rs.Edit
410 rs("NoJob") = FormatNumber((dblGross - rs!Amount) * -1)
420 rs.Update
430 rs.Edit
440 rs("Overhead_Gross") = FormatNumber(rs!overhead_gross + rs!NoJob)
450 rs("TotalGross") = FormatNumber(dblGross + rs!NoJob, 0)
460 rs.Update
470 dblGross = 0
490 rs.MoveNext
500 Loop
510 End If
520 rs.Close
530 Set rs = Nothing
540 Set db = Nothing
Exit Sub
PutTotals_err:
Debug.Print "PutTotals", Erl, Err.Number, Err.Description
End Sub
Private Sub PutOverhead(sTableName As String)
On Error GoTo PutOverhead_err
'*** uses payroll to determine the percent of TotalOverhead to apply to each job
'*** gets the Total Payroll for all JOBs (excluding overhead payroll) as dblPayroll
'*** gets each Job Payroll as dblJobPayroll
'*** calculates percent of payroll attributable to each job as dblPercentPayroll
'*** adds all the job payroll percents and prints the total in the immediate window
'*** this should always equal 1 (for 100%)
100 Dim dblPayroll As Double, dblJobPayroll As Double
110 Dim dblPercentPayroll As Double, dblTotalPercent As Double
120 Dim db As DAO.Database, rs As DAO.Recordset, i As Integer, sFieldName As String
'*** get the total payroll from the Amount column (original Profit Report by TotalOnly)
'----------------------------------------------------------------------------------------------------------------
'!!!!!////////////////////// MAKE SURE YOU REPLACE 'Total 66000 · Payroll Expenses' \\\\\\\\\\\\\\\\\\\\\\\\\\\
'!!!!!\\\\\\\\\\\\\\\\\\\\ WITH THE NAME OF YOUR TOTAL PAYROLL ACCOUNT FROM QUICKBOOKS ////////////////////
'----------------------------------------------------------------------------------------------------------------
130 dblPayroll = _
Nz(DLookup("[Amount]", sTableName, "[Description]='Total 66000 · Payroll Expenses'"), 0)
'*** subtract the Overhead Payroll from dblPayroll for the Payroll attributable to jobs as dblPayroll
140 dblPayroll = _
dblPayroll - Nz(DLookup("[Overhead_Gross]", _
sTableName, "[Description]='Total 66000 · Payroll Expenses'"), 0) '*** REPLACE 'Total 66000 · Payroll Expenses'
'*** format dblPayroll
150 dblPayroll = FormatNumber(dblPayroll, 0)
'*** open the Main table as a recordset
210 Set db = CurrentDb
220 Set rs = db.OpenRecordset(sTableName)
230 If rs.RecordCount > 0 Then
240 rs.MoveLast
250 rs.MoveFirst
'*** LOOP through COLUMNS stopping at each "_Gross" EXCEPT "Overhead_Gross"
'*** these are the JOBS or CUSTOMERS
310 For i = 0 To rs.Fields.Count - 1
320 If rs.Fields(i).Name Like "*_gross*" And InStr(1, rs.Fields(i).Name, "overhead", vbTextCompare) = 0 Then
'*** Get each Job's payroll with DLookup
'----------------------------------------------------------------------------------------------------------------
'!!!!!////////////////////// MAKE SURE YOU REPLACE 'Total 66000 · Payroll Expenses' \\\\\\\\\\\\\\\\\\\\\\\\\\\
'!!!!!\\\\\\\\\\\\\\\\\\\\ WITH THE NAME OF YOUR TOTAL PAYROLL ACCOUNT FROM QUICKBOOKS ////////////////////
'----------------------------------------------------------------------------------------------------------------
330 dblJobPayroll = _
Nz(DLookup(rs.Fields(i).Name, sTableName, "[Description]='Total 66000 · Payroll Expenses'"), 0)
'*** Divide the Job's payroll by the Total Payroll to get each Job's Percent of Payroll
360 If Nz(dblPayroll, 0) <> 0 Then dblPercentPayroll = FormatNumber(dblJobPayroll / dblPayroll, 2)
'*** start a new LOOP for each JOB
370 rs.MoveFirst
'*** LOOP through each JOB's RECORDS multiplying each Overhead_Gross value by dblPercentPayroll
'*** this gives you the portion of overhead attributable to each job
'*** store that value in the JOB_OH field which is represented by rs(sFieldName)
380 Do While Not rs.EOF
390 sFieldName = Replace(rs.Fields(i).Name, "_Gross", "_OH")
400 rs.Edit
410 rs(sFieldName).Value = FormatNumber(Nz(rs("overhead_gross") * dblPercentPayroll, 0), 0)
420 rs.Update
430 rs.MoveNext
440 Loop
450 End If 'THIS IS A "_Gross" COLUMN AND ALSO NOT THE OVERHEAD_Gross COLUMN
'*** RESET VARIABLES FOR NEXT COLUMN LOOP
460 dblJobPayroll = 0
470 dblPercentPayroll = 0
480 Next i 'COLUMN
510 End If 'RS.RECORDCOUNT>0
520 rs.Close
530 Set rs = Nothing
540 Set db = Nothing
Exit Sub
PutOverhead_err:
Debug.Print "PutOverhead", Erl, Err.Number, Err.Description
End Sub
Private Sub PutNet(sTableName As String)
On Error GoTo PutNet_err
'*** LOOP THROUGH COLUMNS ADDING EACH JOB_GROSS TO EACH JOB_OH TO GET EACH JOB_NET
150 Dim db As DAO.Database, rs As DAO.Recordset, i As Integer, sFieldName As String, dblTotalNets As Double
210 Set db = CurrentDb
220 Set rs = db.OpenRecordset(sTableName)
230 If rs.RecordCount > 0 Then
240 rs.MoveLast
310 For i = 0 To rs.Fields.Count - 1
250 rs.MoveFirst
320 If rs.Fields(i).Name Like "*_Net" Then
330 sFieldName = Replace(rs.Fields(i).Name, "_Net", "")
340 Do While Not rs.EOF
350 rs.Edit
360 rs(sFieldName & "_Net").Value = Nz(rs(sFieldName & "_Gross").Value + rs(sFieldName & "_OH").Value, 0)
370 rs.Update
380 rs.MoveNext
390 Loop
400 End If ' COLUMNNAME LIKE "*_NET"
410 Next i ' COLUMN
420 End If 'RS.RECORDCOUNT>0
430 rs.Close
440 Set rs = Nothing
450 Set db = Nothing
Exit Sub
PutNet_err:
Debug.Print "PutNet", Erl, Err.Number, Err.Description
End Sub
Private Sub TotalNets(sTableName As String)
On Error GoTo TotalNets_err
'*** LOOP THROUGH COLUMNS ADDING ALL THE JOB_NETS AND PUTTING THEM IN THE TOTALNETS FIELDS
100 Dim db As DAO.Database, rs As DAO.Recordset, i As Integer, sFieldName As String, dblTotal As Double
110 Set db = CurrentDb
120 Set rs = db.OpenRecordset(sTableName)
130 If rs.RecordCount > 0 Then
140 rs.MoveLast
150 rs.MoveFirst
160 Do While Not rs.EOF
170 For i = 0 To rs.Fields.Count - 1 'COLUMNS
180 If rs.Fields(i).Name Like "*_Net" Then
190 sFieldName = Replace(rs.Fields(i).Name, "_Net", "")
200 dblTotal = dblTotal + rs.Fields(i).Value
210 End If 'COLUMN NAME LIKE "*_NET"
220 Next i 'COLUMN
230 rs.Edit
240 rs("TotalNets").Value = dblTotal
250 rs.Update
260 dblTotal = 0
270 rs.MoveNext
280 Loop
290 End If 'RS.RECORDCOUNT>0
300 rs.Close
310 Set rs = Nothing
320 Set db = Nothing
Exit Sub
TotalNets_err:
Debug.Print "TotalNets", Erl, Err.Number, Err.Description
End Sub
Function fncColumn(sCustomer As String) As String
On Error GoTo fncColum_err
'*** REMOVE CHARACTERS THAT CAUSE ERRORS IN COLUMN NAMES
'*** ADD MORE IF NECESSARY
'*** USE AN ARRAY IF NECESSARY
100 fncColumn = Replace(Replace(sCustomer, " ", ""), "-", "")
110 fncColumn = Replace(fncColumn, "&", "")
120 fncColumn = Trim(Left(fncColumn, 8))
Exit Function
fncColum_err:
Debug.Print "fncColumn", Erl, Err.Number, Err.Description
End Function
Private Sub cmdDropCustomerGrossColumns_Click()
Dim db As DAO.Database, td As DAO.TableDef, i As Integer
Set db = CurrentDb
Set td = db.TableDefs("profitbycustomer")
For i = 0 To td.Fields.Count - 1
If td.Fields(i).Name Like "*_Gross" Then
Call fncRunSQL("ALTER TABLE PROFITBYCUSTOMER DROP COLUMN " & td.Fields(i).Name)
End If
Next i
Set td = Nothing
Set db = Nothing
End Sub
Private Sub cmdDropCustomerOHColumns_Click()
Dim db As DAO.Database, td As DAO.TableDef, i As Integer
Set db = CurrentDb
Set td = db.TableDefs("profitbycustomer")
For i = 0 To td.Fields.Count - 1
If td.Fields(i).Name Like "*_OH" Then
Call fncRunSQL("ALTER TABLE PROFITBYCUSTOMER DROP COLUMN " & td.Fields(i).Name)
End If
Next i
Set td = Nothing
Set db = Nothing
End Sub
Function fncQODBCQuery(sSQL As String, blnReturnsRecords As Boolean, Optional q As String = "qryTemp")
Dim db As Database, qd As QueryDef
Set db = CurrentDb
Set qd = db.CreateQueryDef(q)
qd.Connect = "ODBC;DSN=QuickBooks Data;SERVER=QODBC"
qd.SQL = sSQL
If blnReturnsRecords = True Then
qd.ReturnsRecords = True
Else
qd.ReturnsRecords = False
qd.Execute
End If
Set qd = Nothing
Set db = Nothing
End Function
Function fncRunSQL(sSQL As String)
DoCmd.SetWarnings False
DoCmd.RunSQL sSQL
DoCmd.SetWarnings True
End Function
Function fncProfitTable(sTableName As String, BegDate As Date, EndDate As Date, Optional sCustomer As String = "")
Dim sDateString As String, sSQL As String, sEntityFilter
If Nz(sCustomer, "") <> "" Then sEntityFilter = ", entityfilterfullnamewithchildren ='" & sCustomer & "'"
sDateString = " datefrom=" & fncQBDate(BegDate) & " ,dateto=" & fncQBDate(EndDate)
sSQL = "sp_report ProfitAndLossStandard show text,label,amount_1 parameters " & sDateString & ", returnrows='All'" & sEntityFilter
Call fncQODBCQuery(sSQL, True)
Call fncRunSQL("select text & label as Description ,fix((nz(amount_1,0)*100)/100) as Amount into " & sTableName & " from qryTemp")
End Function
Function fncAddField(sTableName As String, sFieldName As String, dbFieldType As String, Optional blnAutoNumber As Boolean = False, Optional iFieldSize As Integer = 255)
Dim db As DAO.Database, td As DAO.TableDef
Set db = CurrentDb
Set td = db.TableDefs(sTableName)
td.Fields.Append td.CreateField(sFieldName, dbFieldType, iFieldSize)
td.Fields.Refresh
If blnAutoNumber = True Then td.Fields(sFieldName).Attributes = dbAutoIncrField
Set td = Nothing
Set db = Nothing
End Function
Function fncDeleteRecord(sTableName As String, sFieldName As String, sFieldValue As String)
On Error GoTo fncDeleteRecord_err
100 Dim db As DAO.Database, td As DAO.TableDef
110 Set db = CurrentDb
120 Set td = db.TableDefs(sTableName)
130 If sFieldValue = "Null" Then
200 Call fncRunSQL("delete from [" & sTableName & "] where isnull([" & sFieldName & "])=true")
210 ElseIf td.Fields(sFieldName).Type = 20 Or td.Fields(sFieldName).Type = 7 Then
220 Call fncRunSQL("delete from [" & sTableName & "] where [" & sFieldName & "]=" & sFieldValue)
230 Else
300 Call fncRunSQL("delete from [" & sTableName & "] where [" & sFieldName & "]='" & sFieldValue & "'")
310 End If
Exit Function
fncDeleteRecord_err:
Call fncWriteError(Now, "", "Module Functions", "Function fncDeleteRecord", Err.Number, Err.Description, Erl)
End Function
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (1)
Author
Commented: