extract only unique data from specific column [closed] - excel

Question

Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 2 years ago.
Improve this question
I have an excel sheet that contained roster of employees.Data such as their shifts example is 0700_1500 and their OFf days.
The roster is exported to excel from oracle.At the end of each column i want to know the unique data(what shifts are their in specific column excluding OFf days.
Below is extract of my code.I want to add one line that ignore cell that contains OFf days and arrange in ascending order to display.
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

Answer 1

Unique Sort With Exceptions (Dictionary)
My setup including the result (in white at the bottom) for the select range A2:J2.
Adjust the values in the constants section as needed.
The Code
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Remarks: All current filters in the worksheet will be turned off.
' Error and empty values are excluded.
' Errors occurring if the columns are greater than the number
' of columns in the Source Range are only handled by the basic
' error handler (clearError).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub createUniqueList()
' Error
' Initialize error handling.
Const ProcName As String = "createUniqueList"
Dim Success As Boolean
On Error GoTo clearError ' Turn on error trapping.
' Constants
Const uniColumn As Long = 1 ' This is also the 'last row column'.
Const excColumn As Long = 1
Const srtColumn As Long = 1
Const EmptyRows As Long = 0 ' Between the source and the result.
Dim Exceptions As Variant
Exceptions = Array("OFF", "LEAVE", "CTC") ' add more...
' Let user select First Data Row Range.
On Error Resume Next
Dim rng As Range
Set rng = Application.InputBox(Prompt:="Select First Data Row", _
Title:="Obtain Range Object", _
Type:=8)
If Err.Number = 424 Then
GoTo UserCanceled
End If
If Err.Number <> 0 Then
GoTo clearError ' Unexpected.
End If
On Error GoTo clearError
' If you're interested in where an error is occurring after this line,
' uncomment the following line.
'On Error GoTo 0
Application.ScreenUpdating = False
' Define Source Range.
' Remove all filters.
Dim ws As Worksheet
Set ws = rng.Worksheet
If ws.FilterMode Then
ws.ShowAllData
End If
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
' Define First Data Row Range (remove possible areas and rows).
Set rng = rng.Areas(1).Rows(1)
' Define First Cell in Unique Column.
Dim cel As Range
Set cel = rng.Cells(uniColumn)
' Define Unique Processing Range.
Dim pRng As Range
Set pRng = cel.Resize(ws.Rows.Count - cel.Row + 1)
' Define Last Cell in Unique Column.
Set cel = pRng.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If cel Is Nothing Then
GoTo ProcExit ' No data in Unique Processing Range.
End If
' Define Source Range.
Set rng = rng.Resize(cel.Row - rng.Row + 1)
' Write values from Source Range to Data Array.
Dim Data As Variant
If rng.Rows.Count < 1 Or rng.Columns.Count > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
End If
' Modify values in Data Array to get unique values.
Dim ColumnsCount As Long
ColumnsCount = UBound(Data, 2)
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim uniCurrent As Variant
Dim excCurrent As Variant
Dim i As Long
Dim j As Long
Dim k As Long
If UBound(Exceptions) >= LBound(Exceptions) Then
' There are exceptions.
For i = 1 To UBound(Data, 1)
uniCurrent = Data(i, uniColumn)
If Not IsError(uniCurrent) And Not IsEmpty(uniCurrent) Then
excCurrent = Data(i, excColumn)
If IsError(Application.Match(excCurrent, Exceptions, 0)) Then
If Not dict.Exists(uniCurrent) Then
dict(uniCurrent) = Empty
k = k + 1
For j = 1 To ColumnsCount
Data(k, j) = Data(i, j)
Next j
End If
End If
End If
Next i
Else
' There are no exceptions: 'Exceptions = Array()'.
For i = 1 To UBound(Data, 1)
uniCurrent = Data(i, uniColumn)
If Not IsError(uniCurrent) And Not IsEmpty(uniCurrent) Then
If Not dict.Exists(uniCurrent) Then
dict(uniCurrent) = Empty
k = k + 1
For j = 1 To ColumnsCount
Data(k, j) = Data(i, j)
Next j
End If
End If
Next i
End If
' Write unique values from Data Array to Target Range.
' Define Target First Cell Range.
Set cel = rng.Cells(1).Offset(rng.Rows.Count + EmptyRows)
Set rng = cel.Resize(k, ColumnsCount)
rng.Value = Data
' Sort Target Range.
rng.Sort Key1:=rng.Cells(1, srtColumn), _
Order1:=xlAscending, _
Header:=xlNo
' Confirm success.
Success = True
GoTo ProcSuccess
ProcExit:
Application.ScreenUpdating = True
If Success Then
MsgBox "Data transferred.", vbInformation, "Success"
Else
MsgBox "Data not transferred.", vbCritical, "Fail"
End If
Exit Sub
ProcSuccess:
Debug.Print "'" & ProcName & "': Success."
GoTo ProcExit
ProcFail:
Debug.Print "'" & ProcName & "': Fail."
GoTo ProcExit
UserCanceled:
Debug.Print "'" & ProcName & "': User canceled."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcFail
End Sub