Case Management System
Complete ticket/case management system with assignment, tracking, timestamps, and team member workload distribution.
486 views
Perfect For:
- IT helpdesk ticketing
- Customer support cases
- Task assignment
- Work queue management
- Service request tracking
VBA Code
' Case Management System
' Sheet structure: CaseID (A), Status (B), AllocatedTo (C), Picked (D), Comment (E),
' ActionTaken (F), PickedTime (G), ActionTime (H), DroppedTime (I)
' Global variable to store active case per user
Public activeCaseID As String
Public activeUser As String
Sub GetWork()
' Assign next available case to team member
On Error GoTo ErrorHandler
' Prompt for team member name
Dim userName As String
userName = InputBox("Enter your name:", "Get Work")
If userName = "" Then Exit Sub
' Check if user has an active case
If activeUser = userName And activeCaseID <> "" Then
MsgBox "You must submit your current case (ID: " & activeCaseID & ") before getting a new one.", vbExclamation
Exit Sub
End If
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Dump")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Find first unassigned case for this user
Dim i As Long
Dim foundCase As Boolean
foundCase = False
For i = 2 To lastRow
If ws.Cells(i, 3).Value = userName And ws.Cells(i, 4).Value = "" Then
' Found available case
Dim caseID As String
Dim caseStatus As String
caseID = ws.Cells(i, 1).Value
caseStatus = ws.Cells(i, 2).Value
' Mark as picked
ws.Cells(i, 4).Value = "Y"
ws.Cells(i, 7).Value = Now ' PickedTime
' Store active case
activeCaseID = caseID
activeUser = userName
' Show case details
MsgBox "Case assigned!" & vbCrLf & vbCrLf & _
"Case ID: " & caseID & vbCrLf & _
"Status: " & caseStatus, vbInformation
foundCase = True
Exit For
End If
Next i
If Not foundCase Then
MsgBox "No available cases assigned to " & userName & ".", vbInformation
End If
Exit Sub
ErrorHandler:
MsgBox "Error getting work: " & Err.Description, vbCritical
End Sub
Sub SubmitCase()
' Submit completed case with action details
On Error GoTo ErrorHandler
' Check if user has an active case
If activeCaseID = "" Then
MsgBox "You don't have an active case to submit.", vbExclamation
Exit Sub
End If
' Prompt for comment and action taken
Dim userComment As String
Dim actionTaken As String
userComment = InputBox("Enter your comment:", "Submit Case - Comment")
If userComment = "" Then
MsgBox "Comment is required.", vbExclamation
Exit Sub
End If
actionTaken = InputBox("Enter action taken:", "Submit Case - Action")
If actionTaken = "" Then
MsgBox "Action taken is required.", vbExclamation
Exit Sub
End If
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Dump")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Find the active case row
Dim i As Long
For i = 2 To lastRow
If ws.Cells(i, 1).Value = activeCaseID Then
' Update case details
ws.Cells(i, 5).Value = userComment ' Comment
ws.Cells(i, 6).Value = actionTaken ' ActionTaken
ws.Cells(i, 8).Value = Now ' ActionTime
ws.Cells(i, 9).Value = Now ' DroppedTime
' Optional: Copy to team member's history sheet
Call CopyToTeamSheet(activeUser, i)
MsgBox "Case " & activeCaseID & " submitted successfully!", vbInformation
' Clear active case
activeCaseID = ""
activeUser = ""
Exit For
End If
Next i
Exit Sub
ErrorHandler:
MsgBox "Error submitting case: " & Err.Description, vbCritical
End Sub
Sub CopyToTeamSheet(userName As String, sourceRow As Long)
' Copy completed case to team member's history sheet
On Error Resume Next
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Dump")
' Create team sheet if doesn't exist
Dim teamSheet As Worksheet
On Error Resume Next
Set teamSheet = ThisWorkbook.Sheets(userName)
On Error GoTo 0
If teamSheet Is Nothing Then
Set teamSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
teamSheet.Name = userName
' Add headers
teamSheet.Cells(1, 1).Value = "CaseID"
teamSheet.Cells(1, 2).Value = "Status"
teamSheet.Cells(1, 3).Value = "Comment"
teamSheet.Cells(1, 4).Value = "Action Taken"
teamSheet.Cells(1, 5).Value = "Completed Time"
' Format headers
teamSheet.Range("A1:E1").Font.Bold = True
End If
' Copy data
Dim nextRow As Long
nextRow = teamSheet.Cells(teamSheet.Rows.Count, "A").End(xlUp).Row + 1
teamSheet.Cells(nextRow, 1).Value = ws.Cells(sourceRow, 1).Value ' CaseID
teamSheet.Cells(nextRow, 2).Value = ws.Cells(sourceRow, 2).Value ' Status
teamSheet.Cells(nextRow, 3).Value = ws.Cells(sourceRow, 5).Value ' Comment
teamSheet.Cells(nextRow, 4).Value = ws.Cells(sourceRow, 6).Value ' ActionTaken
teamSheet.Cells(nextRow, 5).Value = ws.Cells(sourceRow, 9).Value ' DroppedTime
End Sub
Sub GenerateWorkloadReport()
' Generate summary of cases by team member
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Dump")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim teamMembers As Object
Set teamMembers = CreateObject("Scripting.Dictionary")
' Count cases per team member
Dim i As Long
For i = 2 To lastRow
Dim member As String
member = ws.Cells(i, 3).Value
If member <> "" Then
If Not teamMembers.Exists(member) Then
teamMembers.Add member, 1
Else
teamMembers(member) = teamMembers(member) + 1
End If
End If
Next i
' Display report
Dim report As String
report = "Workload Report:" & vbCrLf & vbCrLf
Dim key As Variant
For Each key In teamMembers.Keys
report = report & key & ": " & teamMembers(key) & " cases" & vbCrLf
Next key
MsgBox report, vbInformation, "Team Workload"
End Sub
Related Topics
case management
ticketing
assignment
workflow
tracking
Need Custom VBA Solutions?
Our AI-powered VBA generator can create custom code tailored to your specific requirements in seconds.
Free AI generations every month — top up with credit packs anytime
Related Templates
More VBA templates in the same category
Intermediate
Sheet Operations Manager
Add, rename, delete, and organise worksheets with advanced options
View Template