Unique list from dynamic range table with possible blanks

Question

I have an Excel table in sheet1 in which column A:

Name of company
Company 1
Company 2

Company 3
Company 1

Company 4
Company 1
Company 3

I want to extract a unique list of company names to sheet2 also in column A. I can only do this with help of a helper column if I dont have any blanks between company names but when I do have I get one more company which is a blank.

Also, I've researched but the example was for non-dynamic tables and so it doesn't work because I don't know the length of my column.

I want in Sheet2 Column A:

Name of company
Company 1
Company 2
Company 3
Company 4

Looking for the solution that requires less computational power Excel or Excel-VBA. The final order which they appear in sheet2 don't really matter.

Answer 1

Here's another method using Excel's built-in Remove Duplicates feature, and a programmed method to remove the blank lines:

EDIT

I have deleted the code using the above methodology as it takes too long to run. I have replaced it with a method that uses VBA's collection object to compile a unique list of companies.

The first method, on my machine, took about two seconds to run; the method below: about 0.02 seconds.

Sub RemoveDups()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim rRes As Range
    Dim I As Long, S As String
    Dim vSrc As Variant, vRes() As Variant, COL  As Collection


Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")
    Set rRes = wsDest.Cells(1, 1)

'Get the source data
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'Collect unique list of companies
Set COL = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1) 'Assume Row 1 is the header
    S = CStr(Trim(vSrc(I, 1)))
    If Len(S) > 0 Then COL.Add S, S
Next I
On Error GoTo 0

'Populate results array
ReDim vRes(0 To COL.Count, 1 To 1)

'Header
vRes(0, 1) = vSrc(1, 1)

'Companies
For I = 1 To COL.Count
    vRes(I, 1) = COL(I)
Next I

'set results range
Set rRes = rRes.Resize(UBound(vRes, 1) + 1)

'Write the results
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit

    'Uncomment the below line if you want
    '.Sort key1:=.Columns(1), order1:=xlAscending, MatchCase:=False, Header:=xlYes

End With

End Sub

NOTE: You wrote you didn't care about the order, but if you want to Sort the results, that added about 0.03 seconds to the routine.

Answer 2

Using a slight modification to Recorder-generated code:

Sub Macro1()
    Sheets("Sheet1").Range("A:A").Copy Sheets("Sheet2").Range("A1")
    Sheets("Sheet2").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
        With Sheets("Sheet2").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A" & Rows.Count) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A2:A" & Rows.Count)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sample Sheet1:

Sample Sheet2:

The sort removes the blanks.

---

EDIT#1:

If the original data in Sheet1 was derived from formulas, then using PasteSpecial will remove unwanted formula copying. There is also a final sweep for empty cells:

Sub Macro1_The_Sequel()
    Dim rng As Range

    Sheets("Sheet1").Range("A:A").Copy
    Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues
    Sheets("Sheet2").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
    Set rng = Sheets("Sheet2").Range("A2:A" & Rows.Count)
    With Sheets("Sheet2").Sort
        .SortFields.Clear
        .SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange rng
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Call Kleanup
End Sub

Sub Kleanup()
    Dim N As Long, i As Long

    With Sheets("Sheet2")
        N = .Cells(Rows.Count, "A").End(xlUp).Row
        For i = N To 1 Step -1
            If .Cells(i, "A").Value = "" Then
                .Cells(i, "A").Delete shift:=xlUp
            End If
        Next i
    End With
End Sub

Answer 3

All of these answers use VBA. The easiest way to do this is to use a pivot table.

First, select your data, including the header row, and go to Insert -> PivotTable:

Then you will get a dialog box. You don't need to select any of the options here, just click OK. This will create a new sheet with a blank pivot table. You then need to tell Excel what data you're looking for. In this case, you only want the Name of company in the Rows section. On the right-hand side of Excel you will see a new section named PivotTable Fields. In this section, simply click and drag the header to the Rows section:

This will give a result with just the unique names and an entry with (blank) at the bottom:

If you don't want to use the Pivot Table further, simply copy and paste the result rows you're interested in (in this case, the unique company names) into a new column or sheet to get just those without the pivot table attached. If you want to keep the pivot table, you can right click on Grand Total and remove that, as well as filter the list to remove the (blank) entry.

Either way, you now have your list of unique results without blanks and it didn't require any formulas or VBA, and it took relatively few resources to complete (far fewer than any VBA or formula solution).

Answer 4

With two sheets named 1 and 2

Inside sheet named: 1

+----+-----------------+
|    |        A        |
+----+-----------------+
|  1 | Name of company |
|  2 | Company 1       |
|  3 | Company 2       |
|  4 |                 |
|  5 | Company 3       |
|  6 | Company 1       |
|  7 |                 |
|  8 | Company 4       |
|  9 | Company 1       |
| 10 | Company 3       |
+----+-----------------+

Result in sheet named: 2

+---+-----------------+
|   |        A        |
+---+-----------------+
| 1 | Name of company |
| 2 | Company 1       |
| 3 | Company 2       |
| 4 | Company 3       |
| 5 | Company 4       |
+---+-----------------+

Use this code in a regular module:

Sub extractUni()
    Dim objDic
    Dim Cell
    Dim Area As Range
    Dim i
    Dim Value

    Set Area = Sheets("1").Range("A2:A10") 'this is where your data is located

    Set objDic = CreateObject("Scripting.Dictionary") 'use a Dictonary!

    For Each Cell In Area
        If Not objDic.Exists(Cell.Value) Then
            objDic.Add Cell.Value, Cell.Address
        End If
    Next

    i = 2 '2 because the heading
    For Each Value In objDic.Keys
        If Not Value = Empty Then
            Sheets("2").Cells(i, 1).Value = Value 'Store the data in column D below the heading
            i = i + 1
        End If
    Next
End Sub

The code return the date unsorted, just the way data appears.

if you want a sorted list, just add this code before the las line:

 Dim sht As Worksheet
    Set sht = Sheets("2")

    sht.Activate
    With sht.Sort
        .SetRange Range("A:A")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

This way the result will be always sorted.

(The subrutine would be like this)

 Sub extractUni()
    Dim objDic
    Dim Cell
    Dim Area As Range
    Dim i
    Dim Value

    Set Area = Sheets("1").Range("A2:A10") 'this is where your data is located

    Set objDic = CreateObject("Scripting.Dictionary") 'use a Dictonary!

    For Each Cell In Area
        If Not objDic.Exists(Cell.Value) Then
            objDic.Add Cell.Value, Cell.Address
        End If
    Next

    i = 2 '2 because the heading
    For Each Value In objDic.Keys
        If Not Value = Empty Then
            Sheets("2").Cells(i, 1).Value = Value 'Store the data in column D below the heading
            i = i + 1
        End If
    Next

    Dim sht As Worksheet
    Set sht = Sheets("2")

    sht.Activate
    With sht.Sort
        .SetRange Range("A:A")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

If you have any question about the code, I will glad to explain.