key sheet based macro

[Tonyk1051]

Hi,

Everyday i have to review changes made by several users and it takes around an hour to do.... in the keysheet attached is a list of categories my dept uses and the word "yes" means he/she is authorized to use that category. to the right is the name of every user and which dept they belong to. Example:some users belong to "warehouse" you'll see that the warehouse users are only allowed to use one or two categories anything else i will mark no in the actual spread sheet "user activity"

In the user activity spreadsheet, tab "category change detail"

the column that says "authorized" i put yes if the categories in column F follow the keysheet, if a cell in column F is blank then i leave it blank, if its a category that not marked yes in the keysheet then i put the word no

when all done i sort the entire spread sheet by column D and look for any duplicates. Any ID which is duplicate I color (light blue) the line that has an earlier date
so ID:7716899 appears twice, one has 5:30pm the other has 6:00pm , the one that is 5:30pm is colored . then i call it day.

hopefully someone can help me

key sheet.xlsx keysheet

RTV User Activity 2023-01-06.xlsm spreadsheet to apply macro

 

[breynolds0431]

See if the below works for you. The first sub, validate(), will populate the "Authorized?" column using the key sheet's data. The next sub, DupCheck(), will sort the "Category Changes Detail" tab by ID and then by time to then identify duplicates and shade the earliest time. Note that the DupCheck is called from the validate code.

Sub validate()

'variables for this workbook and external workbook
Dim tWB As Workbook: Set tWB = ThisWorkbook
Dim tWS As Worksheet: Set tWS = tWB.Sheets("Category Changes Detail")
Dim xWB As Workbook: Set xWB = Workbooks("key sheet.xlsx")
Dim xWS As Worksheet: Set xWS = xWB.Sheets("Sheet1")

'variables for loop
Dim uID As Variant, cID As Integer, cat As Integer, c As Range
Dim lrow As Long: lrow = tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row
Dim ulRng As Range: Set ulRng = xWB.Sheets(1).Columns("M:N")

'loops through each row of tWS
For Each c In tWS.Range("A2:A" & lrow).Cells
    'As long as the category is not blank, then loop continues
    If Not tWS.Cells(c.Row, 6).Value = "" Then

        'gets group from username
        If IsError(Application.VLookup(c.Value, ulRng, 2, False)) Then
            uID = ""
        Else
            uID = Application.VLookup(c.Value, ulRng, 2, False)
        End If
        
        'finds column of group
        If IsError(Application.Match(uID, xWS.Rows(1), 0)) Then
            cID = 0
        Else
            cID = Application.Match(uID, xWS.Rows(1), 0)
        End If
        
        'finds row of category
        If IsError(Application.Match(tWS.Cells(c.Row, 6), xWS.Columns(1), 0)) Then
            cat = 0
        Else
            cat = Application.Match(tWS.Cells(c.Row, 6), xWS.Columns(1), 0)
        End If
        
        'if any above variables were in error, then Authorized? will equal "Error"
        If uID = "" Or cID = 0 Or cat = 0 Then
           tWS.Cells(c.Row, 7).Value = "Error"
        Else
            'if key sheet has a blank, then Authorized? = no
            If xWS.Cells(cat, cID).Value = "" Then
                tWS.Cells(c.Row, 7).Value = "no"
            Else
                'returns actual value found in key sheet
                tWS.Cells(c.Row, 7).Value = LCase(xWS.Cells(cat, cID).Value)
            End If
        End If
    End If
Next c

Call DupCheck

End Sub

Sub DupCheck()

'book and sheet variables
Dim tWB As Workbook: Set tWB = ThisWorkbook
Dim tWS As Worksheet: Set tWS = tWB.Sheets("Category Changes Detail")

'variables for sort
Dim lrow As Long: lrow = tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row
Dim rng1 As Range: Set rng1 = tWS.Range("D2:D" & lrow)
Dim rng2 As Range: Set rng2 = tWS.Range("C2:C" & lrow)

'sorts data
With tWS.Sort
    .SortFields.Clear
    .SortFields.Add2 Key _
        :=rng1, SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    .SortFields.Add2 Key _
        :=rng2, SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    .SetRange tWS.Range("A1:L" & lrow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

'duplicate evaluation
Dim c As Range

With tWS
    'loops through IDs to find duplicates
    For Each c In rng1.Cells
        If Not c.Row = 1 Then
            'since the data is sorted by ID and then by time, this should shade
            'the earliest time of the duplicate ID found
            If .Cells(c.Row, 4).Value = .Cells(c.Row + 1, 4).Value Then
                If Not .Cells(c.Row - 1, 4).Value = .Cells(c.Row, 4).Value Then
                    .Cells(c.Row, 3).Interior.ColorIndex = 37
                End If
            End If
        End If
    Next c
End With
End Sub

During my testing, the loop that I created found some variances in the original Authorized column. I'm providing those below. See the last two columns, where the above code completed column H. Column I identifies the variances from the original "Authorized?" to the code's "Authorized?".

RTV User Activity 2023-01-06.xlsm
	A	B	C	D		F	G	H	I
1	User ID	Date	Time	Item ID		New Category	Authorized?	Authorized?	test
4	tonyk	Jan 5, 2023	11:14:42 AM	6972234		LSI	yes	no	FALSE
5	tonyk	Jan 5, 2023	9:07:27 AM	7325452		LSI	yes	no	FALSE
59	matomecs	Jan 5, 2023	11:26:28 AM	7795382		ORDERED PART		Error	FALSE
64	sscelza	Jan 5, 2023	1:12:24 PM	7798152		ORDERED PART		yes	FALSE
78	sscelza	Jan 5, 2023	2:38:40 PM	7802357		ORDERED PART		yes	FALSE
324	tonyk	Jan 5, 2023	5:16:31 PM	7830256		DENIED DEFECT	yes	no	FALSE
Category Changes Detail

Cell Formulas
Range	Formula
I4:I5,I59,I64,I78,I324	I4	=H4=G4

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
D:D	Cell Value	duplicates	text	NO

 

[Tonyk1051]

Hi Breynolds,

I really appreciate you helping me out, saved me a couple 100 bucks and my job
2 things happened when i ran the macro.
The link in the file i used to copy paste the macro is below. The dup works, correct duplicates were highlighted in blue BUT the authorize column did not populate
i tried changing the tabname to match the name you had in your code
here is the error i got, not sure if it helps but the amount of lines for this report usually varies from a couple 100 to a 1000

User Activity.xlsm (file i used)

 

[breynolds0431]

Hi. Is the key sheet file open? If not, code could be added to open it and close it if needed. But it does need to be open based on the code I wrote. Also, the file extension is needed. The original file on dropbox was titled "key sheet.xlsx". That was the filename used in the xWB variable.

 

[Tonyk1051]

Hi. Is the key sheet file open? If not, code could be added to open it and close it if needed. But it does need to be open based on the code I wrote. Also, the file extension is needed. The original file on dropbox was titled "key sheet.xlsx". That was the filename used in the xWB variable.

no it wasnt open but its much more preferred to use the file i just gave as the keysheet is the next tab over, that way when i pull the data all i have to do just copy the data to the macro file and run it

 

[Alex Blakenburg]

Since you still seem to be online. For a quick and dirty modification, just point the xWB at the other workbook or remove that line and point the xWS at that workbook eg

' Either
Dim xWB As Workbook: Set xWB = tWB           ' or ThisWorkbook
Dim xWS As Worksheet: Set xWS = xWB.Sheets("keysheet")

' OR
Dim xWB As Workbook: Set xWB = Workbooks("key sheet.xlsx")    ' Remove this
Dim xWS As Worksheet: Set xWS = tWB.Sheets("keysheet")           ' and change this

 

[Tonyk1051]

Since you still seem to be online. For a quick and dirty modification, just point the xWB at the other workbook or remove that line and point the xWS at that workbook eg

' Either
Dim xWB As Workbook: Set xWB = tWB           ' or ThisWorkbook
Dim xWS As Worksheet: Set xWS = xWB.Sheets("keysheet")

' OR
Dim xWB As Workbook: Set xWB = Workbooks("key sheet.xlsx")    ' Remove this
Dim xWS As Worksheet: Set xWS = tWB.Sheets("keysheet")           ' and change this

alright ill try that and let you know

 

[Tonyk1051]

alright ill try that and let you know

everything works as it should but with some very minor issues.. what happens when i have to add new employees ? can i just add them to the keysheet and just re run the macro?

 

[Tonyk1051]

Hi. Is the key sheet file open? If not, code could be added to open it and close it if needed. But it does need to be open based on the code I wrote. Also, the file extension is needed. The original file on dropbox was titled "key sheet.xlsx". That was the filename used in the xWB variable.

it works thanks to you and alex, i just need to know how do i go about the process when i get new employees/users..

 

[Alex Blakenburg]

how do i go about the process when i get new employees/users..

The way breynolds0431 has written the code adding more user names in the user to group mapping table will work fine.
Adding more user "columns" however will move columns M:N which are hard coded in the code.

Change the line of code below and that should address the additional column issue.

' Replace the next line
'Dim ulRng As Range: Set ulRng = xWB.Sheets(1).Columns("M:N")
' With this line
Dim ulRng As Range: Set ulRng = xWS.Cells(1, Columns.Count).End(xlToLeft).CurrentRegion