Import from list to table

[Closed]
Report
-
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
-
Hello,

I have a list of user ID's, Users & roles allowed on an application.
I now need to make a table with users & user names and a place an x under the roles that each user is allowed for.

eg the list i have
0101 smarties Gate1
0101 smarties Gate2
0101 smarties Gate4
0101 smarties Gate5
0102 Chappies Gate1
0102 Chappies Gate3
0102 Chappies Gate5

the table i need to put it into

Gate1 Gate2 Gate3 Gate4 Gate5
0101 Smarties X X X X
0102 Chappies X X X


please help


1 reply

Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
803
the main data will be like this with column headings from A1 to C8

hdng1 hdng2 hdng3
101 smarties Gate1
101 smarties Gate2
101 smarties Gate4
101 smarties Gate5
102 Chappies Gate1
102 Chappies Gate3
102 Chappies Gate5

run the macro test

Sub test()
    Dim r As Range, runique As Range, cunique As Range, rcrit As Range
    Dim rab As Range, x As String, y As String, z As String, filt As Range
    Dim rc As Range, c As Range
    Dim ra As Range, rb As Range, m As Long
    Dim j As Long, k As Long, gate As Range, n As Long, gater As Range

    Application.ScreenUpdating = False
undo
Worksheets("sheet1").Activate
    Set rcrit = Range("F1")
    Set runique = Range("A1").End(xlDown).Offset(5, 0)
    Set r = Range("A1").CurrentRegion
    Set rab = r.Resize(r.Rows.Count, 2)
    'MsgBox rab.Address

    r.Sort key1:=Range("a1"), key2:=Range("B1"), header:=xlYes
    Set ra = r.Columns("A:A")
    Set rb = r.Columns("B:B")
    Set rc = r.Columns("C:C")
    'MsgBox rc.Address
    rab.AdvancedFilter xlFilterCopy, , runique, True
    rc.AdvancedFilter xlFilterCopy, , Range("z1"), True
    Range(Range("z2"), Range("z2").End(xlDown)).Sort key1:=Range("z1"), header:=xlNo
    Range(Range("z2"), Range("z2").End(xlDown)).Copy
    runique.Offset(0, 2).PasteSpecial , Transpose:=True
    Range("Z1").EntireColumn.Delete
    m = WorksheetFunction.CountA(Range(Range("F2"), Range("F2").End(xlDown)))
    j = runique.End(xlDown).Row
    k = runique.End(xlToRight).Column
    For Each cunique In Range(runique.Offset(1, 0), runique.End(xlDown))
        r.AutoFilter field:=1, Criteria1:=cunique.Value
        r.AutoFilter field:=2, Criteria1:=cunique.Offset(0, 1).Value
        Set filt = r.Offset(1, 0).Resize(r.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        Set ra = filt.Columns("A:A")
        Set rb = filt.Columns("B:B")
        Set rc = filt.Columns("C:C")
        'For n = runique.Offset(1, 0).Row To j
        Set gate = Range(cunique.Offset(0, 2), Cells(cunique.Row, k))
       ' MsgBox gate.Address
        For Each c In gate
            c.Formula = "=sumproduct((" & ra.Address & "=" & Cells(c.Row, 1).Address & _
                        ")*(" & rb.Address & "=" & Cells(c.Row, 2).Address & ")*(" & _
                        rc.Address & "=" & Cells(cunique.End(xlUp).Row, c.Column).Address & "))"
            If c = 1 Then
                c = "X"
            Else
                c = ""
            End If
        Next
        'Next c
        ActiveSheet.AutoFilterMode = False
    Next
    
    MsgBox "macro over"
    Application.ScreenUpdating = True
End Sub




Sub undo()
    Worksheets("sheet1").Activate
    Range(Range("A1").End(xlDown).Offset(1, 0), Cells(Rows.Count, "A")).EntireRow.Delete

End Sub