VBA test

claude.vba

Option Explicit

' Global variable to track if an update is being processed
Private IsProcessingUpdate As Boolean

' ===== Worksheet Events =====

' Triggered when worksheet changes
Private Sub Worksheet_Change(ByVal Target As Range)
    ' Avoid recursive triggers
    If IsProcessingUpdate Then Exit Sub
    
    ' Set status flag
    IsProcessingUpdate = True
    
    ' Output message to Immediate window
    Debug.Print "Change event triggered for: " & Target.Address
    
    ' Calculate and update all statuses
    UpdateAllStatuses
    
    ' Reset status flag
    IsProcessingUpdate = False
End Sub

' Triggered when worksheet is activated
Private Sub Worksheet_Activate()
    Debug.Print "Worksheet activated, recalculating all statuses..."
    UpdateAllStatuses
End Sub

' Main function: Update all statuses
Public Sub UpdateAllStatuses()
    Debug.Print "Starting update of all statuses..."
    
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' Find all Status cells that need calculation
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim i As Long
    For i = 2 To lastRow ' Start from row 2 (skip header row)
        If Not IsEmpty(ws.Cells(i, 5)) Then ' Check Status column (column 5)
            ' Update status for current row
            UpdateSingleStatus i
        End If
    Next i
    
    Debug.Print "All statuses updated successfully"
End Sub

' Update a single status and output relationships
Public Sub UpdateSingleStatus(ByVal statusRow As Long)
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' Find all item statuses corresponding to current status
    Dim taskName As String
    Dim itemRows As Collection
    
    ' Get task name for current status (column 3 - Task)
    taskName = GetTaskForStatusRow(statusRow)
    
    ' Find all item statuses related to this task
    Set itemRows = FindRelatedItemStatusRows(statusRow, taskName)
    
    ' Output relationship information
    OutputRelationship statusRow, itemRows
    
    ' Calculate and update status value
    CalculateAndUpdateStatus statusRow, itemRows
End Sub

' Get Task name for a Status row
Private Function GetTaskForStatusRow(ByVal statusRow As Long) As String
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' Look up until finding a row where Task (column 3) is not empty
    Dim currentRow As Long
    currentRow = statusRow
    
    While currentRow >= 2 ' Don't go beyond header row
        If Not IsEmpty(ws.Cells(currentRow, 3)) Then
            GetTaskForStatusRow = ws.Cells(currentRow, 3).Value
            Exit Function
        End If
        currentRow = currentRow - 1
    Wend
    
    GetTaskForStatusRow = "Task name not found"
End Function

' Find all Item Status rows related to specified Status row
Private Function FindRelatedItemStatusRows(ByVal statusRow As Long, ByVal taskName As String) As Collection
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim result As New Collection
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' Include the status row itself if it has an Item Status value
    If Not IsEmpty(ws.Cells(statusRow, 7)) Then
        result.Add statusRow
    End If
    
    ' Find the range of item status rows (after current Status row, before next Task)
    Dim startRow As Long
    startRow = statusRow + 1
    
    Dim endRow As Long
    endRow = lastRow
    
    Dim i As Long
    ' Check all rows in range, find rows where Item Status (column 7) is not empty
    For i = startRow To endRow
        ' If a new Task is found, end search
        If Not IsEmpty(ws.Cells(i, 3)) And i > statusRow Then
            endRow = i - 1
            Exit For
        End If
        
        ' If this is an Item Status row
        If Not IsEmpty(ws.Cells(i, 7)) Then
            result.Add i
        End If
    Next i
    
    Set FindRelatedItemStatusRows = result
End Function

' Output relationship between Status row and corresponding Item Status rows
Private Sub OutputRelationship(ByVal statusRow As Long, ByVal itemRows As Collection)
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' Get the task name for this status row
    Dim taskName As String
    taskName = GetTaskForStatusRow(statusRow)
    
    Debug.Print "--------------------"
    Debug.Print "Status row " & statusRow & " (Task: " & taskName & ") contains these Item Status rows:"
    
    Dim i As Long
    For i = 1 To itemRows.Count
        Dim itemRow As Long
        itemRow = itemRows(i)
        
        Dim itemValue As String
        itemValue = "empty"
        If Not IsEmpty(ws.Cells(itemRow, 7)) Then
            itemValue = ws.Cells(itemRow, 7).Value
        End If
        
        Debug.Print "  - Row " & itemRow & " (Value: " & itemValue & ")"
    Next i
    
    Debug.Print "--------------------"
End Sub

' Extract numeric value from a string that might contain a percentage
Private Function ExtractValue(ByVal inputStr As String) As Double
    Debug.Print "Extracting value from: """ & inputStr & """"
    
    Dim result As Double
    result = 0
    
    ' If empty, return 0
    If Len(Trim(inputStr)) = 0 Then
        Debug.Print "  - Empty string, returning 0"
        ExtractValue = 0
        Exit Function
    End If
    
    ' Clean the input
    Dim cleanStr As String
    cleanStr = Trim(inputStr)
    
    ' Check for the X->Y% pattern first
    If InStr(cleanStr, "->") > 0 Then
        Dim parts As Variant
        parts = Split(cleanStr, "->")
        
        If UBound(parts) >= 1 Then
            ' Get the right side of the arrow
            cleanStr = Trim(parts(1))
            Debug.Print "  - Arrow format detected, using: " & cleanStr
        End If
    End If
    
    ' Remove % sign if present
    If InStr(cleanStr, "%") > 0 Then
        cleanStr = Replace(cleanStr, "%", "")
        cleanStr = Trim(cleanStr)
        Debug.Print "  - Percentage sign removed: " & cleanStr
    End If
    
    ' Try to convert to number
    On Error Resume Next
    result = CDbl(cleanStr)
    
    If Err.Number <> 0 Then
        Debug.Print "  - Error converting to number: " & Err.Description
        Err.Clear
        
        ' Try text matching as fallback
        Select Case UCase(inputStr)
            Case "COMPLETED", "DONE", "FINISHED"
                result = 100
                Debug.Print "  - Matched 'COMPLETED/DONE/FINISHED': 100"
            Case "IN PROGRESS", "ONGOING", "PARTIAL"
                result = 50
                Debug.Print "  - Matched 'IN PROGRESS/ONGOING/PARTIAL': 50"
            Case "NOT STARTED", "PENDING", "TODO"
                result = 0
                Debug.Print "  - Matched 'NOT STARTED/PENDING/TODO': 0"
            Case Else
                result = 0
                Debug.Print "  - No match found, using 0"
        End Select
    Else
        ' Check for decimal percentage (like 0.XX instead of XX%)
        If result > 0 And result <= 1 Then
            Debug.Print "  - Small decimal detected (" & result & "), converting to percentage: " & (result * 100)
            result = result * 100
        End If
        
        Debug.Print "  - Numeric value extracted: " & result
    End If
    On Error GoTo 0
    
    ExtractValue = result
End Function

' Calculate and update status value
Private Sub CalculateAndUpdateStatus(ByVal statusRow As Long, ByVal itemRows As Collection)
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' If no related Item Statuses, don't update
    If itemRows.Count = 0 Then
        Debug.Print "Row " & statusRow & " Status has no corresponding Item Status rows, no update performed"
        Exit Sub
    End If
    
    ' Calculate sum and count of all Item Statuses
    Dim sum As Double
    sum = 0
    
    Debug.Print "Processing " & itemRows.Count & " item status values:"
    
    Dim i As Long
    For i = 1 To itemRows.Count
        Dim itemRow As Long
        itemRow = itemRows(i)
        
        ' Convert Item Status value to number and add to sum
        If Not IsEmpty(ws.Cells(itemRow, 7)) Then
            ' Get the raw text value
            Dim rawValue As String
            rawValue = CStr(ws.Cells(itemRow, 7).Value)
            
            ' Extract numeric value
            Dim extractedValue As Double
            extractedValue = ExtractValue(rawValue)
            
            Debug.Print "  Item #" & i & " (Row " & itemRow & "): " & rawValue & " -> " & extractedValue
            
            sum = sum + extractedValue
        End If
    Next i
    
    ' Calculate average
    Dim average As Double
    average = sum / itemRows.Count
    
    ' Make sure we're showing whole percentages
    average = Round(average)
    
    Debug.Print "Sum: " & sum & ", Count: " & itemRows.Count & ", Average: " & average
    
    ' Update Status value with the percentage
    Debug.Print "Setting row " & statusRow & " Status to: " & average & "%"
    
    ' Prevent triggering Change event again
    Application.EnableEvents = False
    
    ' Set the value directly as a number with percentage format
    ws.Cells(statusRow, 5).Value = average
    ws.Cells(statusRow, 5).NumberFormat = "0%"
    
    ' If you prefer to use text format (like "95%"), uncomment this line instead:
    ' ws.Cells(statusRow, 5).Value = average & "%"
    
    Application.EnableEvents = True
End Sub

' Public function to manually trigger all status updates
Public Sub ManualUpdateAllStatuses()
    Debug.Print "Manually triggering update of all statuses..."
    UpdateAllStatuses
End Sub

' Manually test status relationship for specific row
Public Sub TestStatusRelationship(ByVal statusRow As Long)
    Debug.Print "Testing status relationship for row " & statusRow & "..."
    
    Dim taskName As String
    taskName = GetTaskForStatusRow(statusRow)
    
    Dim itemRows As Collection
    Set itemRows = FindRelatedItemStatusRows(statusRow, taskName)
    
    OutputRelationship statusRow, itemRows
End Sub

' Test the calculation of a specific status row without updating
Public Sub TestStatusCalculation(ByVal statusRow As Long)
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' Find all item statuses corresponding to current status
    Dim taskName As String
    Dim itemRows As Collection
    
    ' Get task name for current status (column 3 - Task)
    taskName = GetTaskForStatusRow(statusRow)
    
    ' Find all item statuses related to this task
    Set itemRows = FindRelatedItemStatusRows(statusRow, taskName)
    
    ' Output relationship information
    OutputRelationship statusRow, itemRows
    
    ' If no related Item Statuses, don't proceed
    If itemRows.Count = 0 Then
        Debug.Print "Row " & statusRow & " Status has no corresponding Item Status rows, no calculation possible"
        Exit Sub
    End If
    
    ' Calculate sum and count of all Item Statuses
    Dim sum As Double
    sum = 0
    
    Debug.Print "Processing " & itemRows.Count & " item status values:"
    
    Dim i As Long
    For i = 1 To itemRows.Count
        Dim itemRow As Long
        itemRow = itemRows(i)
        
        ' Convert Item Status value to number and add to sum
        If Not IsEmpty(ws.Cells(itemRow, 7)) Then
            ' Get the raw text value
            Dim rawValue As String
            rawValue = CStr(ws.Cells(itemRow, 7).Value)
            
            ' Extract numeric value
            Dim extractedValue As Double
            extractedValue = ExtractValue(rawValue)
            
            Debug.Print "  Item #" & i & " (Row " & itemRow & "): " & rawValue & " -> " & extractedValue
            
            sum = sum + extractedValue
        End If
    Next i
    
    ' Calculate average
    Dim average As Double
    average = sum / itemRows.Count
    
    ' Make sure we're showing whole percentages
    average = Round(average)
    
    Debug.Print "Sum: " & sum & ", Count: " & itemRows.Count & ", Average: " & average
    Debug.Print "Current status value: " & ws.Cells(statusRow, 5).Value
    Debug.Print "Calculated new status value: " & average & "%"
End Sub

gemini.vba

' ***** In the Worksheet Module (e.g., Sheet1) *****
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    ' --- Announce that the code is running ---
    Debug.Print "--------------------------------------------------"
    Debug.Print "Worksheet_Change triggered by change in cell: " & Target.Address & " at " & Format(Now, "yyyy-mm-dd hh:mm:ss")
    Debug.Print "Initiating Status Update Process..."

    ' --- Temporarily disable events to prevent infinite loops ---
    ' --- Writing to the Status cell would otherwise trigger this Change event again ---
    Application.EnableEvents = False

    ' --- Call the main update routine ---
    ' --- The 'Me' keyword refers to the worksheet object where this code resides ---
    ' --- Make sure 'Module1' matches the actual name of your Standard Module ---
    Call Module1.UpdateAllStatuses(Me)

' --- Ensure events are re-enabled, regardless of errors ---
ExitHere:
    Application.EnableEvents = True
    Debug.Print "Status Update Process Completed."
    Debug.Print "--------------------------------------------------"

End Sub


' ***** In a Standard Module (e.g., Module1) *****
Option Explicit

' --- Define column constants for easier maintenance ---
Public Const TASKFORCE_COL As Long = 1  ' A
Public Const CATEGORY_COL As Long = 2   ' B
Public Const TASK_COL As Long = 3       ' C
Public Const DUE_COL As Long = 4        ' D
Public Const STATUS_COL As Long = 5     ' E
Public Const TASK_ITEMS_COL As Long = 6 ' F
Public Const ITEM_STATUS_COL As Long = 7 ' G
Public Const ITEM_DUE_COL As Long = 8    ' H
Public Const CLOSED_COL As Long = 9     ' I

' --- Main update procedure: Iterates through all rows and processes status for each Task ---
Public Sub UpdateAllStatuses(ByVal ws As Worksheet)
    Dim lastRow As Long
    Dim currentRow As Long
    Dim taskStartRow As Long

    ' --- Basic error handling ---
    On Error GoTo ErrorHandler

    Debug.Print "--> Running UpdateAllStatuses Sub..."

    ' --- Find the last row likely containing data (based on Item Status column) ---
    ' --- You might change this column if another is more suitable for your data ---
    lastRow = ws.Cells(ws.Rows.Count, ITEM_STATUS_COL).End(xlUp).Row
    If lastRow < 2 Then
        Debug.Print "---> No data found below row 1. Exiting UpdateAllStatuses."
        Exit Sub ' Exit if no data
    End If

    Debug.Print "---> Checking rows from 2 to " & lastRow

    ' --- Loop starting from the second row (assuming row 1 is the header) ---
    For currentRow = 2 To lastRow
        ' --- Identify the start row of a Task ---
        ' --- Criterion: Task column (C) is not empty ---
        ' --- Based on your description, the Status and first Item Status are on the Task's start row ---
        If Not IsEmpty(ws.Cells(currentRow, TASK_COL).Value) Then
            taskStartRow = currentRow ' Record the starting row number of the Task
            Debug.Print "---> Found potential Task starting at row " & taskStartRow
            ' --- Process the status calculation for this Task ---
            Call ProcessSingleTaskStatus(ws, taskStartRow)
        End If
    Next currentRow

    Debug.Print "--> UpdateAllStatuses Sub finished normally."
    Exit Sub ' Normal exit

ErrorHandler:
    ' --- Print error information if something goes wrong ---
    Debug.Print "!!! Error in UpdateAllStatuses: " & Err.Description & " (Error No. " & Err.Number & ")"
    ' --- More detailed error handling logic could be added here ---
    ' --- e.g., Resume Next would ignore the error and continue, but might hide problems ---
    ' Resume Next
End Sub

' --- Processes the status calculation for a single Task ---
Public Sub ProcessSingleTaskStatus(ByVal ws As Worksheet, ByVal taskStartRow As Long)
    Dim itemStartRow As Long
    Dim itemEndRow As Long
    Dim nextRow As Long
    Dim itemStatusRange As Range
    Dim calculatedStatus As Variant
    Dim sumStatus As Double
    Dim countStatus As Long
    Dim cell As Range
    Dim itemRowsList As String
    Dim i As Long

    ' --- Local error handling ---
    On Error GoTo ErrorHandler

    Debug.Print "----> Processing Status for Task starting at row " & taskStartRow

    ' --- Based on your description, Item Status starts on the same row as the Task ---
    itemStartRow = taskStartRow
    itemEndRow = itemStartRow ' Default the Item range to include only the start row

    ' --- Find the last row of Item Statuses for this Task ---
    ' --- Look downwards from the next row until the start of the *next* Task (Column C non-empty) or end of data ---
    ' --- Need to check up to the actual last used row + 1 to handle the very last task correctly ---
    Dim checkUntilRow As Long
    checkUntilRow = ws.Cells(ws.Rows.Count, ITEM_STATUS_COL).End(xlUp).Row + 1

    For nextRow = itemStartRow + 1 To checkUntilRow
         If nextRow > ws.Rows.Count Then ' Prevent checking beyond the worksheet's limits
             itemEndRow = nextRow - 1
             Exit For
         End If

        ' --- If the Task column (C) in the next row is NOT empty, it marks a new Task ---
        If Not IsEmpty(ws.Cells(nextRow, TASK_COL).Value) Or nextRow = checkUntilRow Then
            itemEndRow = nextRow - 1 ' Then the previous row was the last Item row for the current task
            Exit For ' Found the end of the range, exit the loop
        End If
    Next nextRow

    ' --- Ensure the end row is not less than the start row (handles tasks with only one item row) ---
    If itemEndRow < itemStartRow Then itemEndRow = itemStartRow

    ' --- Define the range of Item Status values ---
    Set itemStatusRange = ws.Range(ws.Cells(itemStartRow, ITEM_STATUS_COL), ws.Cells(itemEndRow, ITEM_STATUS_COL))

    ' --- [User Requirement] Print the Status Row and the Item Status Rows it includes ---
    itemRowsList = "" ' Reset the list string
    For i = itemStartRow To itemEndRow
        itemRowsList = itemRowsList & i & ", "
    Next i
    If Len(itemRowsList) > 2 Then itemRowsList = Left(itemRowsList, Len(itemRowsList) - 2) ' Remove trailing ", "
    Debug.Print "------> Status Row " & taskStartRow & " (Cell " & ws.Cells(taskStartRow, STATUS_COL).Address(False, False) & ") includes Item Status from rows: " & itemRowsList & " (Range " & itemStatusRange.Address(False, False) & ")"

    ' --- Calculate the "Sum / Count" (Average) of Item Status ---
    ' --- Manual calculation handles non-numeric values and blanks better ---
    sumStatus = 0