• Home
 · 
• Databases/Data Access/DAO/ADO
 · 
• Rollup task for MS Project2000 in MS Access database. Updates the calculations for an individuals p

Rollup task for MS Project2000 in MS Access database. Updates the calculations for an individuals p

Rollup task for MS Project2000 in MS Access database. Updates the calculations for an individuals project table, and then for the whole

Rate Rollup task for MS Project2000 in MS Access database. Updates the calculations for an individuals p

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

Dim rst(4) As DAO.Recordset
Dim dbs As DAO.Database
Dim w As Integer
Dim X As Long
Dim Y As Integer
Dim z As Integer
Dim strParentOutlineNum As String
Dim strParentOutlineNumOrig As String
Dim b As Integer
Dim intCountOfRollup As Long
Dim strOutlineCriteria As String
Dim CostField As String

'==================================================================
'This function calculates all of the Actual Cost for the user's
'individual table, and for the whole project.
'It uses the Outline numbers to determine what is to be
'calculated to where.
'==================================================================

'Determine if this i a user table or project table to
'calculate and change the query fields accordingly.

If tblName = "MSP_TASKS" Then
    CostField = "TASK_ACWP"
Else
    CostField = "ActualCost"
End If

Set dbs = CurrentDb
Set rst(1) = dbs.OpenRecordset("SELECT * FROM " & tblName _
            & " ORDER By TASK_OUTLINE_NUM DESC;")

strParentOutlineNum = rst(1)!TASK_OUTLINE_NUM

'This counts the length of the outline number to determain
'the length of the string to search backwards with.

Y = Len(rst(1)!TASK_OUTLINE_NUM)
w = 0

rst(1).Close
GoSub RotateNumber

'Trim every digit begining with the last and back, to determain a search
'string to retrieve all actual cost numbers within that outline number.

CalcCriteria:

Y = Len(strParentOutlineNum)
w = 0
Do Until Y = 0
    If Mid(strParentOutlineNum, Y, 1) = "." Then
            strOutlineCriteria = Left(strParentOutlineNum, Y) & "*"
            strParentOutlineNum = Left(strParentOutlineNum, Y - 1)
            Debug.Print " Parent Outline Criteria:" & " " & strParentOutlineNum
        If w = 0 Then
            w = w + 1
        End If
        Exit Do
    Else
        strParentOutlineNum = Left(strParentOutlineNum, Y - 1)
        w = w + 1
        Y = Y - 1
    End If
Loop

'Counts all records and stores them
'in the variable intCountOfRollup

Set rst(2) = dbs.OpenRecordset("SELECT " & CostField & ",TASK_OUTLINE_NUM FROM " & tblName _
    & " WHERE task_outline_num LIKE '" & strOutlineCriteria & "';")
b = Len(strOutlineCriteria)
intCountOfRollup = 0
Do Until rst(2).EOF
    COuntline = rst(2)!TASK_OUTLINE_NUM
    If Len(COuntline) > b + 1 Then
        rst(2).MoveNext
    Else
        If CostField = "TASK_ACWP" Then
            X = rst(2)!TASK_ACWP
            intCountOfRollup = intCountOfRollup + rst(2)!TASK_ACWP
            rst(2).MoveNext
        Else
            X = rst(2)!ActualCost
            intCountOfRollup = intCountOfRollup + rst(2)!ActualCost
            rst(2).MoveNext
        End If
            
    End If
Loop
rst(2).Close

'Parses the wildcard and "." to
'create a parent number for the next lookup

strParentOutlineNum = Left(strOutlineCriteria, Len(strOutlineCriteria) - 2)

'Opens a recordset and puts the total
'of intCountOfRollup in the 'CostField' Field.

Set rst(3) = dbs.OpenRecordset("SELECT " & CostField & " FROM " & tblName _
            & " WHERE task_outline_num like '" & strParentOutlineNum & "';")
If rst(3).RecordCount = 0 Then
    GoTo RotateNumber:
Else
     With rst(3)
        If CostField = "TASK_ACWP" Then
            .Edit
            !TASK_ACWP = intCountOfRollup
            .Update
            .MoveNext
        Else
            .Edit
            !ActualCost = intCountOfRollup
            .Update
            .MoveNext
        End If
    End With
End If
rst(3).Close

'Rotates the Parent number for the
'next search criteria.

RotateNumber:

intRowCount = intRowCount = -1
strParentOutlineNumOrig = strParentOutlineNum
Y = Len(strParentOutlineNum)
w = 0

'Decrement the next parent digit if the last
'outline number is 0. This is used for numbers
'2 and up. See next level for 1 and down.

If Right(strParentOutlineNum, 1) < 1 Then
    w = 1
    GoTo NextLevel
End If

Do Until Y = 0
    If Mid(strParentOutlineNum, Y, 1) = "." Then
        strParentOutlineNum = Left(strParentOutlineNum, Y)
        z = Right(strParentOutlineNumOrig, w) - 1
        strParentOutlineNum = strParentOutlineNum & z
        Debug.Print " Parent Outline Criteria: " & strParentOutlineNum
        Exit Do
    Else
        w = w + 1
        Y = Y - 1
        strParentOutlineNum = Left(strParentOutlineNum, Y)

    End If
Loop

NextLevel:

'This does the same as Rotate number, but also determains if
'you are at the beginning of the outline numbers

If Right(strParentOutlineNum, 2) = ".0" Then
    If Len(strParentOutlineNum) = 2 Then
        Exit Function
    Else
        strParentOutlineNum = Left(strParentOutlineNum, Len(strParentOutlineNum) - 1)
        GoTo CalcCriteria
    End If
ElseIf Right(strParentOutlineNum, w) = 0 Then
    Y = Len(strParentOutlineNum)
    strParentOutlineNum = Left(strParentOutlineNum, Y - w - 1)
    z = Right(strParentOutlineNum, w) - 1
    Y = Y - 2
    strParentOutlineNum = Left(strParentOutlineNum, Y - w) & z & "."
    Debug.Print " Parent Outline Criteria: " & strParentOutlineNum
ElseIf strParentOutlineNum = "1.1" Then
    strParentOutlineNum = "1."
    Exit Function
ElseIf strParentOutlineNum = "1" Then
    Exit Function
Else
    strParentOutlineNum = strParentOutlineNum & "."
End If

'Opens the recordset with the next number in rotation
'and determains if the outline number is assigned
'for calculation. If not, rotate to the next number.

FindRows:

Set rst(4) = dbs.OpenRecordset("select " & CostField & ",task_outline_num from " & tblName _
            & " where task_outline_num like '" & strParentOutlineNum & "*' " _
            & "order by TASK_OUTLINE_NUM desc;")

If rst(4).RecordCount = 0 Then
    strParentOutlineNum = Left(strParentOutlineNum, Len(strParentOutlineNum) - 1)
    rst(4).Close
    GoSub RotateNumber:
Else
    strParentOutlineNum = rst(4)!TASK_OUTLINE_NUM
    rst(4).Close
    GoSub CalcCriteria:
End If

End Function