VBA - List out Rights from corresponding table

[Sour Leaf]

Hi,

I have two separate tables (one is a list of Users and User Profiles and the other is a corresponding list of User Profiles and what rights each has)

TABLE 1 - Users and User Profiles
[TABLE="class: grid, width: 1000"]
<tbody>[TR]
[TD]USERS[/TD]
[TD="align: center"]Accounts[/TD]
[TD="align: center"]Admin[/TD]
[TD="align: center"]Master Roster[/TD]
[TD="align: center"]Extrant[/TD]
[TD="align: center"]Basic MIS[/TD]
[TD="align: center"]MIS[/TD]
[TD="align: center"]Sunk VTS[/TD]
[TD="align: center"]VTS[/TD]
[/TR]
[TR]
[TD]User 1[/TD]
[TD="align: center"][/TD]
[TD="align: center"]X[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]User 2[/TD]
[TD][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"]X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]User 3[/TD]
[TD="align: center"]X[/TD]
[TD="align: center"][/TD]
[TD="align: center"]X[/TD]
[TD="align: center"][/TD]
[TD="align: center"]X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]User 7[/TD]
[TD="align: center"]X[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]User 8[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"]X[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"]X[/TD]
[TD="align: center"][/TD]
[TD="align: center"]X[/TD]
[/TR]
[TR]
[TD]User 9[/TD]
[TD="align: center"]X[/TD]
[TD="align: center"]X[/TD]
[TD="align: center"]X[/TD]
[TD="align: center"]X[/TD]
[TD="align: center"][/TD]
[TD="align: center"]X[/TD]
[TD="align: center"][/TD]
[TD="align: center"]X[/TD]
[/TR]
</tbody>[/TABLE]

TABLE 2 - User Profiles and Rights
[TABLE="class: grid, width: 1000"]
<tbody>[TR]
[TD]RIGHTS[/TD]
[TD]Accounts[/TD]
[TD]Admin[/TD]
[TD]Master Roster[/TD]
[TD]Extrant[/TD]
[TD]Basic MIS[/TD]
[TD]MIS[/TD]
[TD]Sunk VTS[/TD]
[TD]VTS[/TD]
[/TR]
[TR]
[TD][TABLE="width: 279"]
<tbody>[TR]
[TD="width: 279"]Pilotage Write[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]X[/TD]
[TD]X[/TD]
[TD][/TD]
[TD]X[/TD]
[TD]X[/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Pilotage Read[/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[/TR]
[TR]
[TD]Roster Write[/TD]
[TD]X[/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[TD]X[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Roster Read[/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[/TR]
[TR]
[TD]Security Write[/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Security Read[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]X[/TD]
[TD][/TD]
[TD]X[/TD]
[/TR]
</tbody>[/TABLE]


What I am after is a list of the Rights each User has in the next coulmn of Table 1 and then offsetting by one column when there is multiple Rights (See below).

[TABLE="class: grid, width: 1000"]
<tbody>[TR]
[TD]USERS[/TD]
[TD="align: center"]Accounts[/TD]
[TD="align: center"]Admin[/TD]
[TD="align: center"]Master Roster[/TD]
[TD="align: center"]Extrant[/TD]
[TD="align: center"]Basic MIS[/TD]
[TD="align: center"]MIS[/TD]
[TD="align: center"]Sunk VTS[/TD]
[TD="align: center"]VTS[/TD]
[TD="align: center"]Right 1[/TD]
[TD="align: center"]Right 2[/TD]
[TD="align: center"]Right 3[/TD]
[/TR]
[TR]
[TD]User 1[/TD]
[TD="align: center"][/TD]
[TD="align: center"]x[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"]Pilotage Write[/TD]
[TD="align: center"]Roster Write[/TD]
[TD="align: center"]Security Write[/TD]
[/TR]
</tbody>[/TABLE]


I have got to the point where i have got the code (see below) to look down one column of User Profiles and return all the Rights but now I am a little stuck.

Sub SearchX()

Dim LR As Long, i As Long, LC As Long
     
    With Sheets("Roles")
        LR = .Range("D" & Rows.Count).End(xlUp).Row
        For i = 1 To LR
            With .Range("D" & i)
                If .Value = "x" Then
                    Sheets("Roles").Range("C" & i).Copy Destination:=Sheets("Roles").Range("AN" & i)
                End If
            End With
        Next i
    End With

End Sub

Any help greatly received, thanks!

 

[MickG]

With your table1 on sheet 1 with the word "USERS" in "A1" and Table 2 on sheet 2 with the word "RIGHTS" in "A1 then try this for results on the end of table 1 in sheet 1.

[COLOR="Navy"]Sub[/COLOR] MG25Jun33
[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] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("B1", .Cells(1, Columns.Count).End(xlToLeft))
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, Array(.Columns(Dn.Column).SpecialCells(xlCellTypeConstants), Dn.Column)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Dim[/COLOR] oHd [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Nam [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] t
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
c = 8
[COLOR="Navy"]For[/COLOR] Ac = 1 To 8
    [COLOR="Navy"]If[/COLOR] Dn.Offset(, Ac).Value = "X" [COLOR="Navy"]Then[/COLOR]
        oHd = Dn.Offset(-Dn.Row + 1, Ac)
            [COLOR="Navy"]If[/COLOR] Dic.exists(oHd) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Nam [COLOR="Navy"]In[/COLOR] Dic(oHd)(0)
                    [COLOR="Navy"]If[/COLOR] Not Nam.Offset(, -Dic(oHd)(1) + 1) = "RIGHTS" [COLOR="Navy"]Then[/COLOR]
                        c = c + 1
                        .Cells(1, c) = "Rights " & c - 8
                        Dn.Offset(, c) = Nam.Offset(, -Dic(oHd)(1) + 1)
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]Next[/COLOR] Nam
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Sour Leaf]

Thank you for this, Mick.

With a bit of adjusting to fit my actual tables this works perfectly!

 

[MickG]

You're welcome