extract unique data

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

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

Answer 3

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