' ----------------------------------------------------------------------------------------------------------------------------------
' VBA Project: Check List
' Module: modCheckList
' Author: Robert Mundigl
' Copyright: © 2012 by Robert Mundigl, Clearly and Simply, www.clearlyandsimply.com. All rights reserved.
' Last edit: 26-August-2012
' Purpose: Change the status of topics and items depending on user Interaction (double click)
' ----------------------------------------------------------------------------------------------------------------------------------
Option Explicit
' Public Constants
Public Const C_DONE = "R" ' Checked box Wingdings2
Public Const C_OPEN = "£" ' Empty box Wingdings2
Public Const C_MIXED = "©" ' Square in box (mixed status) Wingdings2
Public Const C_SEPARATOR = "." ' Separator between topic no and item no
Function IsTopic(varCheckNumber As Variant) As Boolean
' Number of the checkitem / topic contains no separator, i.e. the user double clicked on a topic
IsTopic = (InStr(varCheckNumber, C_SEPARATOR) = 0) And (varCheckNumber <> vbNullString)
End Function
Function IsItem(ByVal varCheckNumber As Variant) As Boolean
' Number of the checkitem / topic contains a separator, i.e. the user double clicked on a check item
IsItem = (InStr(varCheckNumber, C_SEPARATOR) > 0) And (varCheckNumber <> vbNullString)
End Function
Sub ChangeTopicStatus()
' Called after user double clicked on the status of a topic
' Set all items of this topic to the status of the topic
Dim varData As Variant
Dim varTopic As Variant
Dim strStatus As String
Dim lngRowCount As Long
Dim lngColumns As Long
On Error Resume Next
' Initialize
lngColumns = Range("myCheckList").Columns.Count
varData = Range("myCheckList")
varTopic = ActiveCell.Offset(0, -lngColumns + 1).Value
strStatus = ActiveCell.Value
' Loop through the entire check list
For lngRowCount = 1 To UBound(varData)
If IsItem(varData(lngRowCount, 1)) Then
If varTopic = Left$(varData(lngRowCount, 1), InStr(varData(lngRowCount, 1), C_SEPARATOR) - 1) Then
' Current item belongs to the selected topic, i.e. the item receives the status of the topic
varData(lngRowCount, lngColumns) = strStatus
End If
End If
Next lngRowCount
' Write the array back to the range
Range("myCheckList") = varData
' Clean up
Set varData = Nothing
Set varTopic = Nothing
End Sub
Sub AutomaticSetTopicStatus()
' Called after the status of an item was changed
' Checks how many items of this topics are already checked:
' 1. all items checked: topic status is set to done
' 2. no item is checked: topic status ist set to open
' 3. otherwise topic status is set to mixed
Dim varData As Variant
Dim varTopic As Variant
Dim lngRowCount As Long
Dim lngColumns As Long
Dim lngTopicRow As Long
Dim lngItems As Long
Dim lngCheckedItems As Long
On Error Resume Next
' Initialize
lngColumns = Range("myCheckList").Columns.Count
varData = Range("myCheckList")
varTopic = Left$(ActiveCell.Offset(0, -lngColumns + 1).Value, InStr(ActiveCell.Offset(0, -lngColumns + 1).Value, C_SEPARATOR) - 1)
' Loop through the entire check list, find the position of the topic,
' detect the number of items of this topic and the number of checked items
For lngRowCount = 1 To UBound(varData)
If varTopic = CStr(varData(lngRowCount, 1)) Then
lngTopicRow = lngRowCount
Else
If IsItem(varData(lngRowCount, 1)) Then
If varTopic = Left$(varData(lngRowCount, 1), InStr(varData(lngRowCount, 1), C_SEPARATOR) - 1) Then
lngItems = lngItems + 1
If varData(lngRowCount, lngColumns) = C_DONE Then lngCheckedItems = lngCheckedItems + 1
End If
End If
End If
Next lngRowCount
' Set the overall status of the topic
If lngCheckedItems = 0 Then
varData(lngTopicRow, lngColumns) = C_OPEN
ElseIf lngCheckedItems = lngItems Then
varData(lngTopicRow, lngColumns) = C_DONE
Else
varData(lngTopicRow, lngColumns) = C_MIXED
End If
' Write array back to the range
Range("myCheckList") = varData
' Clean up
Set varData = Nothing
Set varTopic = Nothing
End Sub
Sub ExpandCollapseItems()
Dim rngCheckList As Range
Dim varTopic As Variant
Dim lngRowCount As Long
On Error Resume Next
' Initialize
Application.ScreenUpdating = False
Set rngCheckList = Range("myCheckList")
varTopic = ActiveCell.Offset(0, -(ActiveCell.Column - rngCheckList.Column)).Value
' Loop through the entire check list and hide the rows belonging to the double clicked topic
For lngRowCount = 1 To rngCheckList.Rows.Count
If IsItem(rngCheckList(lngRowCount, 1)) Then
If (varTopic = Left$(rngCheckList(lngRowCount, 1).Value, InStr(rngCheckList(lngRowCount, 1).Value, C_SEPARATOR) - 1)) Then _
rngCheckList.Cells(lngRowCount, 1).EntireRow.Hidden = Not rngCheckList.Cells(lngRowCount, 1).EntireRow.Hidden
End If
Next lngRowCount
' Clean up
Set varTopic = Nothing
Application.ScreenUpdating = True
End Sub
Public Function CompletionRate(rngCheckList As Range) As Double
' User defined function: calculate the actual completion rate = number of checked items / number of items
Dim lngRowCount As Long
Dim lngCheckedItems As Long
Dim lngItems As Long
Dim lngColumns As Long
On Error Resume Next
' Initialize
lngColumns = rngCheckList.Columns.Count
For lngRowCount = 1 To rngCheckList.Rows.Count
If IsItem(rngCheckList(lngRowCount, 1)) Then
lngItems = lngItems + 1
If rngCheckList(lngRowCount, lngColumns) = C_DONE Then
' Item is checked
lngCheckedItems = lngCheckedItems + 1
End If
End If
Next lngRowCount
CompletionRate = lngCheckedItems / lngItems
End Function
Bedankt!