Get the list from a table headers drop down

[nemmi69]

Instead of reinventing the wheel is there a way to get the unique list that shows in a headers drop down?

 

[jdellasala]

Doesnt that just return the headers?

Yeah. That's what you asked for - "a way to get the unique list that shows in a headers drop down?". The formulas will work for any single row/column range.
As you might already know, the Data Validation List now allows typing in the DV cell, and values beginning with whatever is typed will filter the list down to those values.

 

[nemmi69]

what I am after is the unique list. So in this case for "Action" it is this

 

[Herakles]

This function will return a comma delimited list of the unique values in the worksheet and column letter
passed as arguments.

Call it like this :

Dim strList As String

strList = fncGetUniqueListFromColumn(Worksheets("DataTest"), "C")

Public Function fncGetUniqueListFromColumn(WsData As Worksheet, strChar As String)
Dim WsActive As Worksheet
Dim rngColumnData As Range
Dim WsUniqueList As Worksheet

On Error GoTo Err_Handler

        Set WsActive = ActiveSheet
                        
        On Error Resume Next
        Worksheets("TempUniqueList").Delete
        On Error GoTo 0
        
        Worksheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = Format(Now(), "ddmmyyyy hhmmss")
        Set WsUniqueList = ActiveSheet
             
        With WsData
            Set rngColumnData = .Range(strChar & 2).Resize(.Cells(WsData.Rows.Count, WsData.Range(strChar & 1).Column).End(xlUp), 1)
            WsUniqueList.Range("A1").Formula2 = "=Unique(" & .Name & "!" & rngColumnData.Address & ", False)"
            WsUniqueList.Range("B1").Formula2 = "=TEXTJOIN("","",TRUE,A:A)"
        End With
        
        fncGetUniqueListFromColumn = WsUniqueList.Range("B1").Value
        
        WsActive.Activate
        
        Application.DisplayAlerts = False
        WsUniqueList.Delete
        Application.DisplayAlerts = True
        
Exit_Handler:

        Exit Function

Err_Handler:

    fncGetUniqueListFromColumn = ""

    Resume Exit_Handler
                
End Function

 

[jdellasala]

what I am after is the unique list. So in this case for "Action" it is this
View attachment 85877

Assuming you want a list of the VALUES in the Action column of a table named Table1:

Book1
	A	B	C	D	E
1	Action		Initial		Initial
2	Initial		New
3	Replacement		Replacement
4	Initial
5	Replacement
6	New
Sheet1

Cell Formulas
Range	Formula
C1:C3	C1	=SORT(UNIQUE(Table1[Action]))
Dynamic array formulas.

Cells with Data Validation
Cell	Allow	Criteria
E1	List	=$A$2:$A$6

Note that the Data Validation list does NOT have duplicate values, and will expand with new values added to the table as will the formula in Column C. The SORT in the formula is unnecessary, but does make it easier to decipher!

 

[nemmi69]

Yep, I tried UNIQUE on the table same as you @jdellasala and it just gave me the header! You would think it would be a table option to get that info

 

[jdellasala]

Yep, I tried UNIQUE on the table same as you @jdellasala and it just gave me the header! You would think it would be a table option to get that info

Check your formula. Did you use

=UNIQUE(Table1[[#Headers],[Action]])

instead of

=UNIQUE(Table1[Action])

The first is only the Column Header row. The second is ALL of the values in the Action column.

 

[Peter_SSs]

In a variable

What about this? Where "Table1" is the name of the table and "Action" is the heading of the table column in question.

Sub Test()
  Dim UniqueValues As Variant
  
  UniqueValues = Evaluate("unique(Table1[Action])")
End Sub

 

[nemmi69]

So this is how I managed -

'#########################################################
'Function DataFromHdr() Checks header exists in table
' and if so gets the table data for that header.
'#########################################################
Function DataFromHdr(ByVal TblName As ListObject, ByVal TblHdrName As String) As Variant
Dim HdrOK As Boolean
Dim HdrChk As Range
Dim DataOK As Boolean
Dim HdrRow As Long
Dim HdrCol As Long
Dim StrRow As Long
Dim StrCol As Long
Dim EndRow As Long
Dim EndCol As Long
Dim HdrRange As Range
Dim DataRng As Variant

' Check the header is in the table
HdrOK = False
For Each HdrRange In TblName.HeaderRowRange.Cells
    If HdrRange.Value = TblHdrName Then
        HdrOK = True
        HdrCol = HdrRange.Column
        Exit For
    End If
Next
If HdrOK = False Then
    DataFromHdr = -3
    Exit Function
End If

' Check the data range is in the table
DataOK = False
' Extract data funder the Header
With TblName.DataBodyRange '.Range
    StrRow = .Row
    EndRow = .Rows.Count + StrRow - 1
    StrCol = .Column
    EndCol = .Columns.Count + StrCol - 1
    
    If HdrCol >= StrCol And HdrCol <= EndCol Then
        DataRng = TblName.ListColumns(TblHdrName).DataBodyRange
    Else
        DataOK = True
        DataFromHdr = -2
        Exit Function
    End If
End With

DataFromHdr = DataRng
End Function

'#########################################################
'Function DelDupArray() Remove blank lines and
' duplicates from an array.
'#########################################################
Function DelDupArray(InputArray As Variant) As Boolean

Dim LBArr As Long, UBArr As Long, NdX As Long
Dim Ast As Long, AEnd As Long, ACnt As Long, BCnt As Long

On Error GoTo ErrorCheck
If IsEmpty(InputArray) Then
    ErrMsg = "No array data."
    GoTo ErrorCheck
End If

DelDupArray = False
LBArr = LBound(InputArray)
UBArr = UBound(InputArray)

'check if 1st element is blank
If InputArray(LBArr) = "" Then
    For NdX = LBArr To UBound(InputArray) - 1
        InputArray(NdX) = InputArray(NdX + 1)
    Next NdX
    ReDim Preserve InputArray(LBound(InputArray) To UBound(InputArray) - 1)
    LBArr = LBound(InputArray)
    UBArr = UBound(InputArray)
End If

'Remove duplicates and blanks
ErrMsg = "Failed removing duplicates and blanks."
Application.StatusBar = "Removing duplicate lines . . ."
Ast = LBArr
AEnd = UBArr
ACnt = Ast
BCnt = Ast + 1

Do While ACnt <= AEnd
    Do While BCnt <= AEnd
        If InputArray(ACnt) = InputArray(BCnt) Or InputArray(BCnt) = "" Then
            For NdX = BCnt To UBound(InputArray) - 1
                InputArray(NdX) = InputArray(NdX + 1)
            Next NdX
            ReDim Preserve InputArray(LBound(InputArray) To UBound(InputArray) - 1)
            AEnd = AEnd - 1
        Else
            BCnt = BCnt + 1
        End If
    Loop
    ACnt = ACnt + 1
    BCnt = ACnt + 1
Loop
DelDupArray = True
On Error GoTo 0
Application.StatusBar = ""

Exit Function

ErrorCheck:
'Reset the application to its normal operating environment.
MsgBox ErrMsg, vbCritical, ThisWorkbook.Name
DelDupArray = False
On Error GoTo 0
Application.StatusBar = ""
End Function

'#########################################################
'Function BubbleSortArray() Sorts array in to ascending
' or descending order. <1 ascending, >=1 descending
'#########################################################
Function BubbleSortArray(InputArray As Variant, ByVal SortOrder As Integer) As Boolean
          Dim TempElement As Variant
          Dim NdX As Integer
          Dim NoExchanges As Integer

On Error GoTo ErrorCheck
If IsEmpty(InputArray) Then
    ErrMsg = "No array data."
    GoTo ErrorCheck
End If

On Error GoTo ErrorCheck
BubbleSortArray = False
ErrMsg = "Array sort failed."
' Loop until no more "exchanges" are made.
Do
    NoExchanges = True
    ' Loop through each element in the array.
    For NdX = 1 To UBound(InputArray) - 1

          If SortOrder < 1 Then '<1 ascending, >=1 descending
               If InputArray(NdX) > InputArray(NdX + 1) Then
                  NoExchanges = False
                  TempElement = InputArray(NdX)
                  InputArray(NdX) = InputArray(NdX + 1)
                  InputArray(NdX + 1) = TempElement
              End If
       Else
              If InputArray(NdX) < InputArray(NdX + 1) Then
                   NoExchanges = False
                   TempElement = InputArray(NdX)
                   InputArray(NdX) = InputArray(NdX + 1)
                   InputArray(NdX + 1) = TempElement
               End If
        End If
    Next NdX
Loop While Not (NoExchanges)
BubbleSortArray = True

Exit Function

ErrorCheck:
'Reset the application to its normal operating environment.
MsgBox ErrMsg, vbCritical, ThisWorkbook.Name
On Error GoTo 0
BubbleSortArray = False
End Function

This is the sub to call that lot

Sub ExractList()

        ' -- Creat unique list of TblHdr sorted ascending
        ' Get list from this worsheets table
        LArr = WorksheetFunction.Transpose(DataFromHdr(TblId, TblHdr))
        If IsNumeric(LArr) Then
            If LArr(1) = -3 Then
                ErrMsg = " Header " & TblHdr & " not found."
            ElseIf LArr(1) = -2 Then
                ErrMsg = " Data for Header " & TblHdr & " not found."
            End If
            GoTo ReportErr
        End If
        ' Create Unique List
        ArrOK = DelDupArray(LArr)
        If ArrOK = False Then
            ErrMsg = " Failed to generate unique list from Header " & TblHdr & " not found."
            GoTo ReportErr
        End If
        ' Sort unique list, ascending
        ArrOK = BubbleSortArray(LArr, 0)
        If ArrOK = False Then
            ErrMsg = " Failed to sort list from Header " & TblHdr & " not found."
            GoTo ReportErr
        End If
End Sub

 

[jdellasala]

Doesnt that just return the headers?

Yes.

 

[Peter_SSs]

So this is how I managed

Really?

I can't see anything in the code that determines what TblId or TblHdr are.
The code has lines like GoTo ReportErr yet there is no such line as ReportErr in the code.

From what I can see, this one line does the same thing as all that code, assuming that TblId and TblHdr have been given appropriate values.

LArr = Evaluate("sort(unique(" & TblId.Name & "[" & TblHdr & "]))")