Inheritance

[rksanthosh]

I have roles in column A and their corresponding entitlement in column B

I need a macro to pick the child role corresponding parent role

Role Entitlement
Role 1 Entitlement 7
Role 1 Entitlement 8
Role 1 Entitlement 9
Role 2 Entitlement 7
Role 2 Entitlement 8
Role 3 Entitlement 6
Role 3 Entitlement 7
Role 3 Entitlement 8
Role 3 Entitlement 9
Role 4 Entitlement 6
Role 5 Entitlement 9

Role 1 inherits Role 2 and Role 5
Role 3 inherits Role 4 and Role 1

Can I have a macro to identify the child roles

 

[Col Delane]

1. What's the logic (rule) of the Role hierarchy (i.e. how do you determine that Role 1 inherits Role 2 and Role 5, and that Role 3 inherits Role 4 and Role 1?)?
2. Subject to the answer to Q1, why do you need a macro - would formulas in columns to the right of Entitlement that identifies the child-parent match not be sufficient?

 

[MickG]

With your data in columns "A & B", try this for results starting column "D".

[COLOR="Navy"]Sub[/COLOR] MG19Feb03
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] R [COLOR="Navy"]As[/COLOR] Range, Rr [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic1 [COLOR="Navy"]As[/COLOR] Object, Dic2 [COLOR="Navy"]As[/COLOR] Object, Dic [COLOR="Navy"]As[/COLOR] Object
 [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
  ReDim ray(1 To Rng.Count, 1 To 2)
  [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
   Dic.CompareMode = vbTextCompare
    [COLOR="Navy"]Set[/COLOR] Dic1 = CreateObject("scripting.dictionary")
      Dic1.CompareMode = vbTextCompare
        ray(1, 1) = "Rol No": ray(1, 2) = "Inherits": c = 1

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic1.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic1.Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic1(Dn.Value) = Union(Dic1(Dn.Value), Dn)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]Set[/COLOR] Dic2 = CreateObject("scripting.dictionary")
Dic1.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Offset(, 1)
        [COLOR="Navy"]If[/COLOR] Not Dic2.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            Dic2.Add Dn.Value, Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic2(Dn.Value) = Union(Dic2(Dn.Value), Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic1.keys
 c = c + 1: Dic.RemoveAll
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dic1(K).Offset(, 1)
        [COLOR="Navy"]If[/COLOR] Dic2.exists(R.Value) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rr [COLOR="Navy"]In[/COLOR] Dic2(R.Value)
                 [COLOR="Navy"]If[/COLOR] Not Rr.Offset(, -1).Value = K [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Rr.Offset(, -1).Value) [COLOR="Navy"]Then[/COLOR]
                    Dic.Add Rr.Offset(, -1).Value, Nothing
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] Rr
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] R
 ray(c, 1) = K
 ray(c, 2) = Join(Dic.keys(), ",")
 [COLOR="Navy"]Next[/COLOR] K

[COLOR="Navy"]With[/COLOR] Range("D1").Resize(c, 2)
    .Value = ray
    .Borders.Weight = 2
    .Columns.AutoFit
    .HorizontalAlignment = xlCenter
 [COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick