Filtering Columns for Unique Values

In cases where the extraction of unique values is used often, I wrote a macro that fulfills the task.
Feel free to use it.

Sub Extract_uniques_to_right_1()

On Error GoTo errorhandling

'Variables definition
Dim ad1 As String
Dim ad2 As String
Dim ad3 As String
Dim msg As String
Dim ans As String
Dim ord_ As String

Dim r1 As Double
Dim r2 As Double
Dim lr As Double

Dim so_c As Integer
Dim so_r As Integer
Dim c1 As Integer
Dim c2 As Integer
Dim c3 As Integer

'Tables or other objects existence control
If ActiveSheet.ListObjects.Count > 0 Then
msg = "Sheet may contain table/s." & vbCr & vbCr & "Macro ends"
MsgBox msg, vbOKOnly + vbInformation, "Oops!"
Exit Sub
End If

'Input dialog and input address
If Selection.Cells.Count <> 1 Then
msg = "Select top label cell to extract unique records"
ad1 = Application.InputBox(msg, Default:=Selection.Address, Type:=8).Address
Else
ad1 = Selection.Address
End If

'Controls. Empty cell selection control
If IsEmpty(Range(ad1)) Then
msg = "Empty cell selected. Macro ends. "
MsgBox msg, vbOKOnly + vbInformation
Exit Sub
End If

'Controls. Multiple cells selection control
If Range(ad1).Cells.Count > 1 Then
msg = "Selection points to more than one cells. Macro ends. "
MsgBox msg, vbOKOnly + vbInformation
Exit Sub
End If

'Range data collection part
With Range(ad1)
r1 = .Row
c1 = .Column
End With

With Range(ad1).CurrentRegion
r2 = .Rows.Count + r1 - 1
c3 = .Column
c2 = .Columns.Count + c3 - 1
lr = .Row + .CurrentRegion.Rows.Count - 1
End With

'Controls. Last row selection control
If r1 = lr Then
msg = "Selection points to last cell of a region. Macro ends. "
MsgBox msg, vbOKOnly + vbInformation
Exit Sub
End If

'Controls. Sheet's columns limit control
If c2 > 255 Then
msg = "Sheets column limits exceeded. Macro ends. "
MsgBox msg, vbOKOnly + vbInformation
Exit Sub
End If

'Setting various application elements to make macro run faster
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

'Copying header to extract area
Range(ad1).Copy Destination:=Range(ad1).Offset(0, c2 - c1 + 1)

'Main part of the macro
Range(Cells(r1, c1), Cells(r2, c1)).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Cells(r1, c2 + 2).Range("a1:a2"), _
CopyToRange:=Cells(r1, c2 + 1), _
Unique:=True

'Adding "U " as "Unique" to header and setting focus on this cell
msg = Range(ad1).Offset(0, c2 - c1 + 1).Value
Range(ad1).Offset(0, c2 - c1 + 1).Value = "U " & msg
Range(ad1).Offset(0, c2 - c1 + 1).Select

'Resetting various application elements
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With

'Sort dialog and action
msg = "Do you want to sort extracted data? " + Chr(13) + Chr(13)
msg = msg + "Yes for ascending" + Chr(13)
msg = msg + "No for descending" + Chr(13)
msg = msg + "Cancel for unsorted"

ans = MsgBox(msg, vbYesNoCancel + vbQuestion)

If ans = 6 Or ans = 7 Then
If ans = 6 Then
ord_ = xlAscending
Else
ord_ = xlDescending
End If

so_c = Selection.Column
so_r = Selection.Row
ad3 = Range(Cells(so_r, so_c), Cells(lr, so_c)).Address

Range(ad3).Sort _
key1:=Cells(so_r, so_c), _
order1:=ord_, _
header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End If

Exit Sub

errorhandling:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.StatusBar = False
.Calculation = xlCalculationAutomatic
End With

'This part handles the "Cancel" button selection of the first dialog
If IsEmpty(ad1) Then
msg = "Cancel selected. Macro ends. "
MsgBox msg, vbOKOnly + vbInformation
Exit Sub
End If

'This part handles other errors if any appears
msg = "Macro encountered an unexpected error and halts" + Chr$(13)
msg = msg + "Please try to re-run checking initial conditions" + Chr$(13) + Chr$(13)
msg = msg + "If the error persists contact the programmer" + Chr$(13)
msg = msg + "thpapavasiliou@yahoo.com"
MsgBox msg, vbOKOnly + vbCritical

End Sub

Coming soon to Office365 is the UNIQUE function, which is an alternative method to getting a list of unique part numbers. See https://support.office.com/en-us/article/unique-function-c5ab87fd-30a3-4ce9-9d1a-40204fb85e1e or https://www.youtube.com/watch?v=vy8y4CN-IHY for its use. I am not sure if it can return the whole table though.

One benefit is that it will update the list of unique part numbers as a new one is added to the table.