extract unique data - excel

Question

I got a sheet that contain weekly roster of each employee. The code below run perfectly to display unique data of one column:
Dim lastrow As Long
Application.ScreenUpdating = False
Dim rng, lastcell As Range
Set rng = Application.InputBox("Select a range", "Obtain Range Object", Type:=8)
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
ActiveSheet.Range(rng.Address & lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=ActiveSheet.Range(rng.Cells(rng.Rows.Count + 1, rng.Columns.Count).Address), _
Unique:=True
Application.ScreenUpdating = True
But my issue is that I want the code to exclude some text like OFF
and LEAVE. The only data to display is their shift which is in the format, 0430_1145 for timein_timeout in an asecending way.
The data normally is displayed at the end of each column:
If column have data such as:
0700_1500
0430_1145
leave
off
0700_1500
0830_1615
result would be(ascending way ignoring off and leave)-
0430_1145
0700_1500
0830_1615
Below is the link of my excel sheet:
https://drive.google.com/file/d/1CYGS9ZgsulG8J_qzYEUXWFiXkBHneibv/edit

Answer 1

If you have O365 with the appropriate functions, you can do this with a worksheet formula:
=SORT(UNIQUE(FILTER(A1:A6,(A1:A6<>"off")*(A1:A6<>"leave"))))
In the below image, the formula is entered into cell A8
Edit: Here is a VBA routine based on the worksheet you uploaded.
The result of the extraction of each column is stored as an ArrayList in a Dictionary.
I used an ArrayList because it is easy to sort -- but you could use any of a number of different objects to store this information, and write a separate sorting routine.
I also used late-binding for the dictionary and arraylist objects, but could switch that to early-binding if you have huge amounts of data to process and need the increased speed.
Note that the data is processed from a VBA array rather than on the worksheet.
many modifications are possible depending on your needs, but this should get you started.
Option Explicit
Sub summarizeShifts()
Dim wsSrc As Worksheet 'data sheet
Dim vSrc As Variant, vRes As Variant 'variant arrays for original data and results
Dim rRes As Range 'destination for results
Dim dShifts As Object ' store shifts for each day
Dim AL As Object 'store in AL to be able to sort
Dim I As Long, J As Long, S As String, V As Variant, W As Variant
'read source data into array
Set wsSrc = Worksheets("fnd_gfm_1292249")
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=9)
Set rRes = .Cells(UBound(vSrc, 1) + 1, 3) 'bottom of source data
End With
Set dShifts = CreateObject("Scripting.Dictionary")
'Populate the dictionary by columns
For J = 3 To UBound(vSrc, 2)
Set AL = CreateObject("System.Collections.ArrayList")
For I = 2 To UBound(vSrc, 1)
S = vSrc(I, J)
If S Like "####_####" Then
If Not AL.contains(S) Then AL.Add S
End If
Next I
AL.Sort
dShifts.Add J, AL
Next J
'size vres
I = 0
For Each V In dShifts
J = dShifts(V).Count
I = IIf(I > J, I, J)
Next V
ReDim vRes(1 To I, 1 To UBound(vSrc) - 2)
'populate results array
For Each V In dShifts
I = 0
For Each W In dShifts(V)
I = I + 1
vRes(I, V - 2) = W
Next W
Next V
'write the results
Application.ScreenUpdating = False
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.Resize(rowsize:=rRes.Rows.Count * 3).ClearContents 'or something to clear rows below the data
.Value = vRes
End With
End Sub

Answer 2

Approach via FilterXML()
In addition to the valid solutions above I demonstrate an alternative solution via FilterXML() available since vers. 2013+:
Sub ExtractUniques20201019()
'a) define Worksheet
Dim ws As Worksheet: Set ws = Sheet1 ' << change to project's sheet Code(Name)
'b) get first target Row (2 rows below original data)
Dim tgtRow As Long: tgtRow = UBound(getData(ws, "A", 1)) + 2
Dim i As Long
For i = 3 To 9 ' columns C:I (Monday to Sunday)
'[1] get data
Dim data: data = getData(ws, i) ' << function call getData()
'[2] get valid unique data
Dim uniques: uniques = getFilterUniques(data) ' << function call getFilterUniques()
BubbleSortColumnArray uniques ' << call procedure BubbleSortColumnArray
'[3] write results to target below data range
ws.Range("A" & tgtRow).Offset(columnoffset:=i - 1).Resize(UBound(uniques), 1) = uniques
Next i
End Sub
Help functions
Function getData(ws As Worksheet, ByVal col, Optional ByVal StartRow& = 2) As Variant()
' Purpose: assign column data to variant array
If IsNumeric(col) Then col = Split(ws.Cells(1, col).Address, "$")(1)
Dim lastRow As Long
lastRow = ws.Range(col & Rows.Count).End(xlUp).Row
getData = ws.Range(col & StartRow & ":" & col & lastRow).Value2
End Function
Function getFilterUniques(arr, Optional Fltr As String = "_")
'Purpose: get unique items containing e.g. Fltr "_" using XPath search
'Note: WorksheetFunction.FilterXML() is available since vers. 2013+
' XPath examples c.f. https://stackoverflow.com/questions/61837696/excel-extract-substrings-from-string-using-filterxml/61837697#61837697
Dim content As String ' well formed xml content string
content = "<t><s>" & Join(Application.Transpose(arr), "</s><s>") & "</s></t>"
getFilterUniques = WorksheetFunction.FilterXML(content, "//s[not(preceding::*=.)][contains(., '" & Fltr & "')]")
End Function
Bubblesort
Sub BubbleSortColumnArray(arr, Optional ByVal ColNo As Long = 1)
'Purpose: sort 1-based 2-dim datafield array
'correct differing column index
Dim colIdx As Long: colIdx = LBound(arr) + ColNo - 1
'bubble sort
Dim cnt As Long, nxt As Long, temp
For cnt = LBound(arr) To UBound(arr) - 1
For nxt = cnt + 1 To UBound(arr)
If arr(cnt, colIdx) > arr(nxt, colIdx) Then
temp = arr(cnt, colIdx) ' remember element
arr(cnt, colIdx) = arr(nxt, colIdx) ' swap
arr(nxt, colIdx) = temp
End If
Next nxt
Next cnt
End Sub

Answer 3

Consider using the one argument of AdvancedFilter you do not use: CriteriaRange. This can allow you to set up a multiple set criteria that leaves out those values. See Microsoft's Filter by using advanced criteria tutorial doc section: Multiple sets of criteria, one column in all sets.
Essentially, this involves adding a new region outside of data region somewhere in worksheet or workbook with column headers and needed criteria which would be <>LEAVE AND <>OFF which as link above shows would require two same named columns for AND logic.
Criteria Region
A B C D E F G H I J K L M N
1 Monday Monday Tuesday Tuesday Wednesday Wednesday Thursday Thursday Friday Friday Saturday Saturday Sunday Sunday
2 <>LEAVE <>OFF <>LEAVE <>OFF <>LEAVE <>OFF <>LEAVE <>OFF <>LEAVE <>OFF <>LEAVE <>OFF <>LEAVE <>OFF
VBA
Below defines worksheet objects and avoids the use of ActiveSheet. See Two main reasons why .Select, .Activate, Selection, Activecell, Activesheet, Activeworkbook, etc. should be avoided.
...
Set data_ws = ThisWorkbook.Worksheets("myCurrentWorksheet")
Set criteria_ws = ThisWorkbook.Worksheets("myCurrentWorksheet")
data_ws.Range(rng.Address & lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=criteria_ws.Range("A1:N2")
CopyToRange:=data_ws.Range(rng.Cells(rng.Rows.Count + 1, rng.Columns.Count).Address), _
Unique:=True