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

USERS	Accounts	Admin	Master Roster	Extrant	Basic MIS	MIS	Sunk VTS	VTS
User 1		X
User 2					X
User 3	X		X		X
User 7	X
User 8			X			X		X
User 9	X	X	X	X		X		X

<tbody>
</tbody>

TABLE 2 - User Profiles and Rights

RIGHTS	Accounts	Admin	Master Roster	Extrant	Basic MIS	MIS	Sunk VTS	VTS
Pilotage Write <tbody> </tbody>	X	X		X	X	X
Pilotage Read			X					X
Roster Write	X	X				X	X
Roster Read			X		X			X
Security Write		X
Security Read						X		X

<tbody>
</tbody>

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).

USERS	Accounts	Admin	Master Roster	Extrant	Basic MIS	MIS	Sunk VTS	VTS	Right 1	Right 2	Right 3
User 1		x							Pilotage Write	Roster Write	Security Write

<tbody>
</tbody>

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