CreateUniqueList

Create list of unique items from a column into another column
This is similar to Column2AnString_Unique except this one is faster, generates the list into another column, and uses "Remove Duplicates" feature in Excel.

CodeFunctionName
What is this?

Public

Tested

Original Work
Function CreateUniqueList(From_ColumnName, Optional From_RowNum = 1, Optional From_SheetName = "Active", Optional From_WB = "This", _
    Optional To_ColumnName = "SameAsFrom", Optional To_SheetName = "Active", Optional To_WB = "This")
    ' Create list of unique items from a column into another column
    ' uses "Remove Duplicates" feature in Excel
    ' Caller can define "FROM" column sheet and workbook, "TO" column, sheet and workbook
    ' This is supposed to be faster since it is using "Remove Duplicates" feature in Excel
    '
    ' Returns number of unique items exported to "TO" column (count includes header row)
    ' Still needs to be tested
    '
    ' Assumes list always have header row
   
    Rett = 0
    If From_SheetName = "Active" Then From_SheetName = ActiveSheet.Name
    If From_WB = "This" Then From_WB = ThisWorkbook.Name
    If From_WB = "Active" Then From_WB = ActiveWorkbook.Name
    If To_SheetName = "Active" Then To_SheetName = ActiveSheet.Name
    If To_WB = "This" Then To_WB = ThisWorkbook.Name
    If To_WB = "Active" Then To_WB = ActiveWorkbook.Name
    If To_ColumnName = "SameAsFrom" Then To_ColumnName = From_ColumnName
   
    If To_ColumnName = From_ColumnName And To_SheetName = From_SheetName And To_WB = From_WB Then
    Else
        ' clearing "TO" column if it is not the same as "FROM"
        Workbooks(To_WB).Worksheets(To_SheetName).Range(To_ColumnName & 1).EntireColumn.ClearContents
    End If
    Rows2Move = Workbooks(From_WB).Worksheets(From_SheetName).Range(From_ColumnName & From_RowNum).CurrentRegion.Rows.Count
   
    Workbooks(To_WB).Worksheets(To_SheetName).Range(To_ColumnName & 1, To_ColumnName & Rows2Move + 1).Value = _
        Workbooks(From_WB).Worksheets(From_SheetName).Range(From_ColumnName & From_RowNum, From_ColumnName & Rows2Move + From_RowNum).Value
   
    ' ActiveSheet.Range("$AA$1:$AE$12").RemoveDuplicates Columns:=2, Header:=xlYes
    Workbooks(To_WB).Worksheets(To_SheetName).Range(To_ColumnName & 1, To_ColumnName & Rows2Move + 1).RemoveDuplicates 1, xlYes
    DoEvents
    Rett = Workbooks(To_WB).Worksheets(To_SheetName).Range(To_ColumnName & 1).CurrentRegion.Rows.Count
   
    CreateUniqueList = Rett
End Function

From_ColumnName, Optional From_RowNum = 1, Optional From_SheetName = "Active", Optional From_WB = "This", _
    Optional To_ColumnName = "SameAsFrom", Optional To_SheetName = "Active", Optional To_WB = "This"

Views 167

Downloads 30

CodeID
DB ID