Der er oprettet to namedranges 'report_criteria_1', 'report_criteria_2' og 'report_sums'
Kriterie områderne indlæses i collections, som benyttes til at validere data op imod.
Data løbes igennem for validering og evt. summering før data skrives til 'report_sums'
Public Sub report_YearToDate()
'Constants
Const colCOST_TEXT As Long = 17 'Q
Const colPOST_TYPE As Long = 11 'K
Const colWBS_TYPE As Long = 1 'A
Const colDATES As Long = 20 'T
Const colWBS_Level As Long = 16 'P
Const colSUM As Long = 21 'U
'Variables
Dim cPostType As New Collection, cWBS_Type As New Collection, cDates As New Collection, cWBS_Level As New Collection, cCostText As New Collection
Dim aCosts As Variant, aSum() As Variant
Dim lRow As Long
'Fill variables
Set cPostType = report_FillFilterCollectons(wsReport.Range("report_criteria_1").Columns(1))
Set cWBS_Type = report_FillFilterCollectons(wsReport.Range("report_criteria_1").Columns(2))
Set cDates = report_FillFilterCollectons(wsReport.Range("report_criteria_1").Columns(3))
Set cWBS_Level = report_FillFilterCollectons(wsReport.Range("report_criteria_1").Columns(4))
Set cCostText = report_FillFilterCollectons(wsReport.Range("report_criteria_2"))
aCosts = wsCosts.Range("A1").CurrentRegion
ReDim aSum(1 To cCostText.Count, 1 To 1) As Variant
'Run through cost data to evaluate
For lRow = LBound(aCosts, 1) To UBound(aCosts, 1)
If InCollection(cCostText, aCosts(lRow, colCOST_TEXT)) Then 'is the current row within the selected external costs then SUM
If InCollection(cPostType, aCosts(lRow, colPOST_TYPE)) Then
If InCollection(cWBS_Type, aCosts(lRow, colWBS_TYPE)) Then
If InCollection(cDates, CStr(aCosts(lRow, colDATES))) Then
If InCollection(cWBS_Level, aCosts(lRow, colWBS_Level)) Then
aSum(cCostText(aCosts(lRow, colCOST_TEXT)), 1) = aSum(cCostText(aCosts(lRow, colCOST_TEXT)), 1) + aCosts(lRow, colSUM)
End If
End If
End If
End If
End If
Next lRow
'Insert data
wsReport.Range("report_sums").ClearContents
wsReport.Range("report_sums").Value = aSum
End Sub
Private Function report_FillFilterCollectons(ByVal headerRange As Range) As Collection
'Function to fill data into a collection
Dim cRetVal As New Collection
Dim lRow As Long
On Error Resume Next 'cRetVal.Add will fail if to of the same keys is added to the collection
For lRow = 2 To headerRange.Rows.Count
If Not headerRange.Cells(lRow, 1).Value = "" Then
cRetVal.Add lRow - 1, CStr(headerRange.Cells(lRow, 1).Value) 'Counter as value and content as key
Else
Exit For
End If
Next lRow
On Error GoTo 0
Set report_FillFilterCollectons = cRetVal
End Function
Public Function InCollection(ByVal colObject As Collection, ByVal keyValue As Variant)
'Function to evaluate if a value is in a collection
On Error Resume Next
colObject keyValue
If Err.Number = 0 Then InCollection = True
On Error GoTo 0
End Function
