Option Explicit
Sub RollingSetback()
'
' constants
Const ksWSInput = "Kaizen Log"
Const ksTeamMembersInput = "TeamMembersTable"
Const ksTypeInput = "TypeList"
Const ksMembersInput = "MembersTable"
Const ksWSOutput = "Kaizens Per Person"
Const ksNamesOutput = "NamesTable"
Const ksDictKey = ",Quick,Standard,Major"
Const ksDictValue = ",4,2,1"
'
' declarations
Dim rngTMI As Range, rngTI As Range, rngMI As Range, rngNO As Range
Dim sDictKey() As String, sDictValue() As String
Dim arrTMI As Variant, arrTI As Variant, arrMI As Variant, arrNO As Variant
Dim sdObj As Scripting.Dictionary, sdType As Scripting.Dictionary
Dim I As Long, J As Long, K As Integer, L As Integer, M As Integer, A As String, B As String
'
' start
With Worksheets(ksWSInput)
' ranges
Set rngTMI = .Range(ksTeamMembersInput)
Set rngTI = .Range(ksTypeInput)
Set rngMI = .Range(ksMembersInput)
' arrays
arrTMI = .Range(ksTeamMembersInput).Value
arrTI = .Range(ksTypeInput).Value
arrMI = .Range(ksMembersInput).Value
End With
With Worksheets(ksWSOutput)
' ranges
Set rngNO = .Range(ksNamesOutput)
' arrays
arrNO = .Range(ksNamesOutput).Value
End With
With rngNO
If .Rows.Count > 1 Then Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
End With
' objects
' 2d
Set sdObj = New Scripting.Dictionary
' 1d
sDictKey() = Split(ksDictKey, ",")
sDictValue() = Split(ksDictValue, ",")
Set sdType = New Scripting.Dictionary
With sdType
For I = 1 To UBound(sDictKey)
.Add sDictKey(I), Val(sDictValue(I))
Next I
End With
'
' process
' ranges
sdObj.RemoveAll
Debug.Print "rng", rngTMI.Rows.Count, rngTMI.Columns.Count, Now(),
With rngMI
For I = 1 To .Rows.Count
' type
B = rngTI.Cells(I, 1).Value
K = sdType(B)
' teams
For J = 1 To .Columns.Count
A = .Cells(I, J).Value
If A <> "" Then
If Not sdObj.Exists(A) Then
' new entry
sdObj.Add A, K
Else
' check if update entry
L = sdObj(A)
M = L And K
If M <> K Then sdObj(A) = (L Or K)
End If
End If
Next J
Next I
End With
Debug.Print Now()
' arrays
sdObj.RemoveAll
Debug.Print "arr", UBound(arrMI, 1), UBound(arrMI, 2), Now(),
For I = 1 To UBound(arrMI, 1)
' type
B = arrTI(I, 1)
K = sdType(B)
' teams
For J = 1 To UBound(arrMI, 2)
A = arrMI(I, J)
If A <> "" Then
If Not sdObj.Exists(A) Then
' new entry
sdObj.Add A, K
Else
' check if update entry
L = sdObj(A)
M = L And K
If M <> K Then sdObj(A) = (L Or K)
End If
End If
Next J
Next I
Debug.Print Now()
' output from dictionary
With sdObj
For I = 0 To .Count - 1
' member
rngNO.Cells(I + 2, 1).Value = .Keys(I)
For J = 2 To 0 Step -1
' team
If (.Items(I) And (2 ^ J)) = (2 ^ J) Then rngNO.Cells(I + 2, 4 - J).Value = "X"
Next J
Next I
End With
'
' end
' objects
Set sdObj = Nothing
' ranges
Set rngNO = Nothing
Set rngMI = Nothing
Set rngTI = Nothing
Set rngTMI = Nothing
'
End Sub
