来自动态范围表的唯一列表，可能包含空格

Question

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

  

公司名称
公司1公司2

公司   3
公司1号公司4公司1公司   3个

我想在A列中提取一个唯一的公司名称列表到Sheet2。如果公司名称之间没有任何空白，我只能在帮助列的帮助下执行此操作但是当我确实有另外一个公司名称时这是一片空白。

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

我想要Sheet2 A列：

  

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

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

Answer 1

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

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

示例 Sheet1 ：

示例 Sheet2 ：

排序会删除空白。

修改＃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

Answer 2

这是使用Excel内置Remove Duplicates功能的另一种方法，以及删除空行的编程方法：

修改

我已使用上述方法删除了代码，因为运行时间太长。我用一个使用VBA集合对象的方法替换它来编译一个独特的公司列表。

第一种方法，在我的机器上，花了大约两秒钟来运行;方法如下：约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秒的例程。

Answer 3

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

首先，选择您的数据，包括标题行，然后转到插入 - ＆gt;数据透视表：

然后你会得到一个对话框。您不需要在此处选择任何选项，只需单击“确定”即可。这将创建一个带有空白数据透视表的新工作表。然后，您需要告诉Excel您要查找的数据。在这种情况下，您只需要“行”部分中的Name of company。在Excel的右侧，您将看到名为PivotTable Fields的新部分。在本节中，只需单击并将标题拖动到“行”部分：

这将只给出一个结果，只有唯一的名称和底部带有(blank)的条目：

如果您不想进一步使用数据透视表，只需将您感兴趣的结果行（在本例中为唯一的公司名称）复制并粘贴到新的列或表中即可获取只是没有附加枢轴表的那些。如果您想保留数据透视表，可以右键单击Grand Total并删除它，并过滤列表以删除(blank)条目。

无论哪种方式，您现在都可以获得没有空白的独特结果列表，并且它不需要任何公式或VBA，并且只需要相对较少的资源（远远少于任何VBA或公式解决方案）。

Answer 4

有两张名为1和2

的纸张

名为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就是这样）

 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

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