dynamic范围表中的唯一列表可能有空白
我在Sheet1中有一个Excel表，其中列A：
公司名称
公司1
公司2公司3
公司1公司4
公司1
公司3
我想提取一个独特的公司名称列表sheet2也列A我只能做一个帮助列的帮助，如果我没有任何公司名称之间的空白，但当我有我得到一个更多的公司，这是一个空白。
另外，我已经研究过，但是这个例子是针对非dynamic表的，所以它不起作用，因为我不知道列的长度。
我想在Sheet2中列A：
公司名称
公司1
公司2
公司3
公司4
寻找需要较less计算能力的解决schemeExcel或Excel-VBA。 它们出现在表2中的最终顺序并不重要。
对logging器生成的代码进行一些修改：
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 ：
示例表2 ：
sorting删除空白。
编辑＃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
所有这些答案都使用VBA。 最简单的方法是使用数据透视表。
首先，select您的数据，包括标题行，并转到插入 – >数据透视表：
然后你会得到一个对话框。 您不需要在这里select任何选项，只需单击确定。 这将创build一个带有空白数据透视表的新工作表。 然后你需要告诉Excel你正在寻找什么数据。 在这种情况下，您只需要“行”部分中Name of company 。 在Excel的右侧，您将看到一个名为PivotTable Fields的新节。 在本节中，只需单击并将标题拖到“行”部分即可：
这将给出一个结果，只有唯一的名字和一个条目(blank)在底部：
如果您不想进一步使用数据透视表，只需将您感兴趣的结果行（在本例中为唯一的公司名称）复制并粘贴到新的列或表格中，以获取没有附加数据透视表的那些行。 如果要保留数据透视表，可以右键单击Grand Total，然后删除它，并筛选列表以删除(blank)条目。
无论哪种方式，您现在都可以得到没有空白的唯一结果列表，并且不需要任何公式或VBA，而且完成所需的资源相对较less（远低于任何VBA或公式解决scheme）。
这是另一种使用Excel的内置Remove Duplicatesfunction的方法，以及一种用于删除空行的程序化方法：
编辑
我使用上述方法删除了代码，因为运行时间太长。 我已经用一个使用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
注意 ：你写的你并不关心订单，但是如果你想对结果进行sorting，那么就增加了大约0.03秒的时间。
用两张名为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
代码返回date未分类，只是数据出现的方式。
如果你想要一个sorting列表，只需在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
这样的结果将永远sorting。
（该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
如果您对代码有任何疑问，我很乐意解释。