List 动态范围表中的唯一列表，可能为空

我在表1中有一个Excel表格，其中A列：

公司名称
公司1
公司2

公司 3公司1公司4公司1公司 3

我想将公司名称的唯一列表提取到sheet2的a列中。如果公司名称之间没有空格，我只能在助手列的帮助下执行此操作，但当我有空时，我会得到另一家公司，这是一个空格

另外，我也做过研究，但这个例子是针对非动态表的，所以它不起作用，因为我不知道我的列的长度

我想在第2页A列：

公司名称
公司1
公司2
公司3
公司4

---

寻找需要较少计算能力的解决方案Excel或Excel VBA。它们在表2中出现的最终顺序实际上并不重要。

对记录器生成的代码稍作修改：

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

样本1：

样本表2：

排序将删除空格

---

编辑#1:

如果Sheet1中的原始数据来自公式，则使用PasteSpecial将删除不需要的公式复制。还有一个空单元格的最终扫描：

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

---

有两张名为

1

和

2

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

内页名称：

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       |
+----+-----------------+

在名为：

2

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

在常规模块中使用此代码：

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

代码返回未排序的日期，只是数据的显示方式

如果需要排序列表，只需在las行之前添加以下代码：

 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

这样，结果将始终被排序

（subrutine将是这样的）

---

如果您对代码有任何疑问，我很乐意解释。

< P>这是另一种使用Excel内置代码<删除重复> <代码>功能的方法，以及一种编程方法来删除空白行：

编辑

我已经用上面的方法删除了代码，因为运行时间太长了。我将其替换为一个方法，该方法使用VBA的collection对象来编译公司的唯一列表

第一种方法，在我的机器上，运行大约需要两秒钟；方法如下：约0.02秒

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

---

注意：你写的不关心顺序，但是如果你想对结果进行排序，这会给例程增加大约0.03秒。

所有这些答案都使用VBA。最简单的方法是使用透视表

首先，选择数据，包括标题行，然后转到插入->数据透视表：

然后会出现一个对话框。您不需要在此处选择任何选项，只需单击“确定”。这将创建一个带有空白透视表的新工作表。然后，您需要告诉Excel您要查找的数据。在这种情况下，您只需要在行部分中输入公司的名称。在Excel的右侧，您将看到一个名为“数据透视表字段”的新部分。在此部分中，只需单击标题并将其拖动到“行”部分：

这将给出一个只包含唯一名称的结果和底部带有

（空白）

的条目：

如果不想进一步使用透视表，只需将感兴趣的结果行（在本例中为唯一的公司名称）复制并粘贴到新的列或表中，即可获得未附加透视表的结果行。如果要保留数据透视表，可以右键单击总计并删除该数据透视表，还可以过滤列表以删除

（空白）

条目

---

无论哪种方式，您现在都有了一个没有空格的独特结果列表，它不需要任何公式或VBA，而且完成它所需的资源相对较少（远远少于任何VBA或公式解决方案）。

您好，@Gary的学生。你在桌子上试过吗？在SeET2的头下，我仍然有空白空间。其余的似乎都是顺理成章的。我根据sheet1的其他列得到了我的公司名称，不确定是否相关。我也切换到自动计算，现在我只得到标题和a#REF！在它下面。我不知道该怎么办。@carlos_cs我将尝试修改代码以处理这两个问题。@carlos_cs查看我的编辑#1:wow，它在不到1秒的时间内完成了我想要的。这一次编辑#1非常有效。嗨，@Elbert Villarreal。我在我的案例中尝试了你代码的排序版本。我在第一行有一个空格，在第二行有一个标题，列表的其余部分在标题下未排序。我不知道为什么会这样。我得到的公司名称是基于sheet1的其他列的公式，不确定是否相关。您的结果没有公式，但在我更改为“自动计算”后，所有结果都保持不变。这些空白单元格真的是空白的吗？？？或者可以是空格或不可打印的字符？如果刷新数据，可以重新运行宏并返回唯一的单元格。您好，我今天重新调整了代码，第一行为空，然后按字母顺序获取所有内容（包括标题）。我相信这是一个真正的空白，但由于它是人工输入的人，我永远不能肯定。在这种情况下，我相信这是一个真正的空白，因为当我点击那个单元格时，我不能从中删除任何内容。您的代码大约需要7秒钟才能完成。标题应该在第一行，其余的应该在下面排序。如果您不知道数据的最后一个单元格，在VBA中很容易得到最后一行。声明一个名为

LastRow

的变量，然后使用以下命令：

LastRow=Range（“A1048576”）.End（xlUp）。row

将给出数据的最后一行，因为y像您一样进入单元格

A1048576

并按CRTL+UpArrow.Hi，@Ron Rosenfeld。我用我的箱子试过你的代码，它完全符合我的要求！我唯一不喜欢的是10k行大约需要20秒。@carlos_cs我没有意识到使用Excel函数需要这么长时间。我将添加另一个使用