Permissions Matrix Report

Sub TransformPermissionsToMatrix()
‘ This macro transforms EHR permissions data into a matrix format
‘ using a clean copy approach instead of modifying the original data

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = True
Application.StatusBar = “Initializing…”

‘ Get the source data sheet
Dim dataSheet As Worksheet
Set dataSheet = ActiveSheet

‘ Create a new sheet for the clean data
Dim cleanSheet As Worksheet, matrixSheet As Worksheet

‘ Check if the sheets already exist, if so, delete them
On Error Resume Next
Set cleanSheet = Worksheets(“CleanData”)
If Not cleanSheet Is Nothing Then
cleanSheet.Delete
End If

Set matrixSheet = Worksheets(“Matrix”)
If Not matrixSheet Is Nothing Then
matrixSheet.Delete
End If
On Error GoTo 0

‘ Add new sheets
Set cleanSheet = Worksheets.Add(After:=dataSheet)
cleanSheet.Name = “CleanData”

Set matrixSheet = Worksheets.Add(After:=cleanSheet)
matrixSheet.Name = “Matrix”

‘ Define the source column positions in the original data
Dim srcRoleCol As Long, srcTemplateCol As Long, srcPermItemCol As Long, srcGrantedCol As Long
srcRoleCol = 2 ‘ RoleName (Column B)
srcTemplateCol = 3 ‘ PermissionTemplateTypeName (Column C)
srcPermItemCol = 4 ‘ PermissionItemName (Column D)
srcGrantedCol = 6 ‘ Granted (Column F)

‘ Define target column positions in the clean sheet
Dim tgtRoleCol As Long, tgtTemplateCol As Long, tgtPermItemCol As Long, tgtGrantedCol As Long
tgtRoleCol = 1 ‘ RoleName (Column A in clean sheet)
tgtTemplateCol = 2 ‘ PermissionTemplateTypeName (Column B in clean sheet)
tgtPermItemCol = 3 ‘ PermissionItemName (Column C in clean sheet)
tgtGrantedCol = 4 ‘ Granted (Column D in clean sheet)

‘ Get the last row with data in the source sheet
Dim lastRow As Long
lastRow = dataSheet.UsedRange.Rows.Count

Application.StatusBar = “Copying needed columns to clean sheet…”

‘ Set up headers in the clean sheet
cleanSheet.Cells(1, tgtRoleCol).Value = “RoleName”
cleanSheet.Cells(1, tgtTemplateCol).Value = “PermissionTemplateTypeName”
cleanSheet.Cells(1, tgtPermItemCol).Value = “PermissionItemName”
cleanSheet.Cells(1, tgtGrantedCol).Value = “Granted”

‘ Copy data to clean sheet
Dim r As Long

For r = 2 To lastRow
‘ Update progress every 1000 rows
If r Mod 1000 = 0 Then
Application.StatusBar = “Copying row ” & r & ” of ” & lastRow & ” (” & Format(r / lastRow, “0%”) & “)”
DoEvents
End If

‘ Copy each cell to the clean sheet
cleanSheet.Cells(r, tgtRoleCol).Value = dataSheet.Cells(r, srcRoleCol).Value
cleanSheet.Cells(r, tgtTemplateCol).Value = dataSheet.Cells(r, srcTemplateCol).Value
cleanSheet.Cells(r, tgtPermItemCol).Value = dataSheet.Cells(r, srcPermItemCol).Value
cleanSheet.Cells(r, tgtGrantedCol).Value = dataSheet.Cells(r, srcGrantedCol).Value
Next r

Application.StatusBar = “Sorting data…”

‘ Sort the clean data by RoleName, PermissionTemplateTypeName, PermissionItemName
With cleanSheet.Sort
.SortFields.Clear
.SortFields.Add key:=cleanSheet.Range(cleanSheet.Cells(1, tgtRoleCol), cleanSheet.Cells(lastRow, tgtRoleCol)), _
SortOn:=xlSortOnValues, Order:=xlAscending
.SortFields.Add key:=cleanSheet.Range(cleanSheet.Cells(1, tgtTemplateCol), cleanSheet.Cells(lastRow, tgtTemplateCol)), _
SortOn:=xlSortOnValues, Order:=xlAscending
.SortFields.Add key:=cleanSheet.Range(cleanSheet.Cells(1, tgtPermItemCol), cleanSheet.Cells(lastRow, tgtPermItemCol)), _
SortOn:=xlSortOnValues, Order:=xlAscending

.SetRange cleanSheet.Range(cleanSheet.Cells(1, 1), cleanSheet.Cells(lastRow, tgtGrantedCol))
.Header = xlYes
.Apply
End With

Application.StatusBar = “Collecting unique values…”

‘ Get unique roles, templates, and permission items
Dim roleDict As Object, templateDict As Object, permItemDict As Object
Set roleDict = CreateObject(“Scripting.Dictionary”)
Set templateDict = CreateObject(“Scripting.Dictionary”)
Set permItemDict = CreateObject(“Scripting.Dictionary”)

‘ Validate clean data
Dim validCount As Long
validCount = 0

For r = 2 To lastRow
Dim role As String, template As String, permItem As String, granted As String

role = cleanSheet.Cells(r, tgtRoleCol).Value
template = cleanSheet.Cells(r, tgtTemplateCol).Value
permItem = cleanSheet.Cells(r, tgtPermItemCol).Value
granted = cleanSheet.Cells(r, tgtGrantedCol).Value

‘ Skip if any critical fields are empty
If Len(role) > 0 And Len(template) > 0 And Len(permItem) > 0 Then
validCount = validCount + 1

‘ Add unique values to dictionaries
If Not roleDict.Exists(role) Then
roleDict.Add role, Nothing
End If

Dim templatePermKey As String
templatePermKey = template & “|” & permItem

If Not templateDict.Exists(template) Then
templateDict.Add template, Nothing
End If

If Not permItemDict.Exists(templatePermKey) Then
permItemDict.Add templatePermKey, Nothing
End If
End If
Next r

‘ Check if we found any valid data
If validCount = 0 Or roleDict.Count = 0 Or permItemDict.Count = 0 Then
MsgBox “No valid data found for processing. Please check that the source data has RoleName, PermissionTemplateTypeName, PermissionItemName, and Granted columns.”, vbExclamation

‘ Show debugging info
Dim debugMsg As String
debugMsg = “Debugging information:” & vbCrLf & vbCrLf
debugMsg = debugMsg & “Total rows in source: ” & lastRow & vbCrLf
debugMsg = debugMsg & “Valid rows found: ” & validCount & vbCrLf
debugMsg = debugMsg & “Unique roles found: ” & roleDict.Count & vbCrLf
debugMsg = debugMsg & “Unique templates found: ” & templateDict.Count & vbCrLf
debugMsg = debugMsg & “Unique permission combinations found: ” & permItemDict.Count & vbCrLf & vbCrLf

‘ Show headers from source data
debugMsg = debugMsg & “Source data headers:” & vbCrLf
For c = 1 To 6
debugMsg = debugMsg & ” Column ” & c & “: [” & dataSheet.Cells(1, c).Value & “]” & vbCrLf
Next c
debugMsg = debugMsg & vbCrLf

‘ Show sample of first few data rows from source
debugMsg = debugMsg & “Sample data from source sheet:” & vbCrLf
For r = 2 To Application.Min(4, lastRow)
debugMsg = debugMsg & “Row ” & r & “:” & vbCrLf
debugMsg = debugMsg & ” Col B (RoleName): [” & dataSheet.Cells(r, srcRoleCol).Value & “]” & vbCrLf
debugMsg = debugMsg & ” Col C (Template): [” & dataSheet.Cells(r, srcTemplateCol).Value & “]” & vbCrLf
debugMsg = debugMsg & ” Col D (PermItem): [” & dataSheet.Cells(r, srcPermItemCol).Value & “]” & vbCrLf
debugMsg = debugMsg & ” Col F (Granted): [” & dataSheet.Cells(r, srcGrantedCol).Value & “]” & vbCrLf & vbCrLf
Next r

‘ Show sample of first few data rows from clean sheet
debugMsg = debugMsg & “Sample data from clean sheet:” & vbCrLf
For r = 2 To Application.Min(4, lastRow)
debugMsg = debugMsg & “Row ” & r & “:” & vbCrLf
debugMsg = debugMsg & ” RoleName: [” & cleanSheet.Cells(r, tgtRoleCol).Value & “]” & vbCrLf
debugMsg = debugMsg & ” Template: [” & cleanSheet.Cells(r, tgtTemplateCol).Value & “]” & vbCrLf
debugMsg = debugMsg & ” PermItem: [” & cleanSheet.Cells(r, tgtPermItemCol).Value & “]” & vbCrLf
debugMsg = debugMsg & ” Granted: [” & cleanSheet.Cells(r, tgtGrantedCol).Value & “]” & vbCrLf & vbCrLf
Next r

MsgBox debugMsg, vbInformation, “Debug Information”

Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If

Application.StatusBar = “Building matrix…”

‘ Set up matrix sheet headers
matrixSheet.Cells(1, 1).Value = “PermissionTemplateTypeName”
matrixSheet.Cells(1, 2).Value = “PermissionItemName”

‘ Add role headers
Dim roleArray() As String
ReDim roleArray(0 To roleDict.Count – 1)

Dim roleKeys As Variant, i As Long
roleKeys = roleDict.Keys
For i = 0 To UBound(roleKeys)
roleArray(i) = roleKeys(i)
Next i

‘ Sort roles alphabetically
Call BubbleSort(roleArray)

‘ Set role names as column headers
For i = 0 To UBound(roleArray)
matrixSheet.Cells(1, i + 3).Value = roleArray(i)
Next i

‘ Create a dictionary to store unique template+permItem combinations
Dim uniquePermissions As Object, permIndex As Long
Set uniquePermissions = CreateObject(“Scripting.Dictionary”)
permIndex = 2 ‘ Start at row 2 in matrix

‘ Collect all unique template+permItem combinations and their values for each role
Dim permStorage As Object
Set permStorage = CreateObject(“Scripting.Dictionary”)

Application.StatusBar = “Processing permissions data…”

‘ First pass to collect all unique permissions and role values
For r = 2 To lastRow
Dim currRole As String, currTemplate As String, currPermItem As String, currGranted As String

currRole = cleanSheet.Cells(r, tgtRoleCol).Value
currTemplate = cleanSheet.Cells(r, tgtTemplateCol).Value
currPermItem = cleanSheet.Cells(r, tgtPermItemCol).Value
currGranted = cleanSheet.Cells(r, tgtGrantedCol).Value

‘ Skip empty rows
If Len(currRole) > 0 And Len(currTemplate) > 0 And Len(currPermItem) > 0 Then
Dim permKey As String, storageKey As String
permKey = currTemplate & “|” & currPermItem
storageKey = permKey & “|” & currRole

‘ Add to unique permissions dictionary if not exists
If Not uniquePermissions.Exists(permKey) Then
uniquePermissions.Add permKey, permIndex
permIndex = permIndex + 1
End If

‘ Store the granted value
permStorage(storageKey) = currGranted
End If
Next r

‘ Create sorted array of unique permissions for consistent ordering
Dim permKeys As Variant
permKeys = uniquePermissions.Keys

Dim permArray() As String
ReDim permArray(0 To UBound(permKeys))

For i = 0 To UBound(permKeys)
permArray(i) = permKeys(i)
Next i

‘ Sort permissions
Call BubbleSort(permArray)

Application.StatusBar = “Building matrix rows…”

‘ Output template and permission item values
For i = 0 To UBound(permArray)
Dim parts As Variant
parts = Split(permArray(i), “|”)

‘ Add template and permission item to matrix
matrixSheet.Cells(i + 2, 1).Value = parts(0) ‘ Template
matrixSheet.Cells(i + 2, 2).Value = parts(1) ‘ Permission Item
Next i

Application.StatusBar = “Filling in permission values…”

‘ Now fill in the granted values for each role
For i = 0 To UBound(permArray)
Dim permissionKey As String
permissionKey = permArray(i)

For j = 0 To UBound(roleArray)
Dim roleName As String
roleName = roleArray(j)

‘ Create the storage key
storageKey = permissionKey & “|” & roleName

‘ Check if this combination exists and add the value
If permStorage.Exists(storageKey) Then
matrixSheet.Cells(i + 2, j + 3).Value = permStorage(storageKey)
End If
Next j

‘ Update progress for large datasets
If i Mod 100 = 0 Then
Application.StatusBar = “Filling in values: ” & Format(i / UBound(permArray), “0%”) & ” complete…”
DoEvents
End If
Next i

Application.StatusBar = “Applying formatting…”

‘ Format the matrix
With matrixSheet.Range(matrixSheet.Cells(1, 1), matrixSheet.Cells(1, UBound(roleArray) + 3))
.Interior.Color = RGB(200, 200, 200)
.Font.Bold = True
End With

‘ Get the used range of the matrix
Dim matrixRange As Range
Set matrixRange = matrixSheet.Range(matrixSheet.Cells(1, 1), _
matrixSheet.Cells(UBound(permArray) + 2, UBound(roleArray) + 3))

‘ Apply conditional formatting for Y/N values
Dim dataRange As Range
Set dataRange = matrixSheet.Range(matrixSheet.Cells(2, 3), _
matrixSheet.Cells(UBound(permArray) + 2, UBound(roleArray) + 3))

With dataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:=”Y”)
.Interior.Color = RGB(200, 255, 200) ‘ Light green
End With

With dataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:=”N”)
.Interior.Color = RGB(255, 200, 200) ‘ Light red
End With

‘ Add filter to header row
matrixSheet.Range(matrixSheet.Rows(1).Address).AutoFilter

‘ Apply borders
matrixRange.Borders.LineStyle = xlContinuous

‘ Autofit columns
matrixSheet.Columns.AutoFit

‘ Freeze panes
matrixSheet.Range(“C2”).Select
ActiveWindow.FreezePanes = True

‘ Make the matrix sheet active
matrixSheet.Activate

‘ Reset application settings
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

‘ Success message
MsgBox “Permissions matrix created successfully.” & vbCrLf & vbCrLf & _
“• ” & roleDict.Count & ” unique roles” & vbCrLf & _
“• ” & uniquePermissions.Count & ” unique permissions” & vbCrLf & _
“• ” & permStorage.Count & ” data points processed”, _
vbInformation, “Matrix Creation Complete”
End Sub

‘ Helper function to sort an array of strings
Sub BubbleSort(arr() As String)
Dim i As Long, j As Long
Dim temp As String

For i = LBound(arr) To UBound(arr) – 1
For j = i + 1 To UBound(arr)
If arr(i) > arr(j) Then
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i
End Sub