VBA - List out Rights from corresponding table

S

Sour Leaf

New Member
Joined
Nov 27, 2014
Messages
42
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.

Code: 
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!
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Sort by date Sort by votes
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.
Code: 
[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
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
VBA that pulls data based on multiple criteria
Replies
0
Views
294
Mouse7681
M
J
  • Locked
  • Question Question
Still need help on a daily summary sheet
Replies
1
Views
582
Fluff
Fluff
T
  • Question Question
Change pivot table source via VBA?
Replies
0
Views
491
TheWennerWoman
T
ajjava
  • Question Question
Procedure to find MAX VALUE in a SPECIFIC pivot table value field, in the case of MULTIPLE pivot table value fields
Replies
0
Views
2K
ajjava
ajjava
S
  • Question Question
Big, Multi-Step Macro for Efficiently Cutting Big Pieces Into Small Pieces
Replies
1
Views
462
Solon Aquila
S

Forum statistics

Threads
1,223,229
Messages
6,170,881
Members
452,364
Latest member
springate

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top