唯一列表與可能的坯料

Question

我有在Sheet Excel表，其中列A：

公司的名稱
公司1
公司2

公司公司1

公司4
公司1家
公司

我想提取的公司名稱，以她獨特的名單et2也在列A中。如果我在公司名稱之間沒有任何空格，但是當我確實有一個空白的公司時，我只能在幫助列的幫助下完成此操作。

另外，我已經研究過，但是這個例子是針對非動態表的，所以它不起作用，因爲我不知道列的長度。

我想在Sheet2的A列：

公司
名稱公司1
公司2
公司3
公司4

尋找需要較少的計算能力的解決方案Excel或Excel-VBA。他們在表2中出現的最終順序並不重要。

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 

樣品Sheet 1中：

樣品Sheet 2中：

該排序刪除空白。

---

EDIT＃1：

如果Sheet 1中原始數據衍生自式中，然後使用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

使用命名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 

代碼返回未排序的日期，只是數據出現的方式。

如果你想有一個排序列表，就在拉斯維加斯行之前添加以下代碼：

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 

如果您對代碼的任何問題，我會很高興來解釋。

Answer 3

下面是使用另一種方法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 4

所有這些答案都使用VBA。最簡單的方法是使用數據透視表。

首先，選擇您的數據，包括標題行，然後轉到插入 - >數據透視表：

然後你會得到一個對話框。您無需在此選擇任何選項，只需單擊確定即可。這將創建一個帶有空白數據透視表的新工作表。然後，您需要告訴Excel您要查找的數據。在這種情況下，您只需要行中的Name of company部分。在Excel的右側，您將看到一個名爲PivotTable Fields的新部分。在本節中，只需點擊標題拖動到在行部分：

這將給只用唯一名稱的結果，並在底部與(blank)的條目：

如果您不想進一步使用數據透視表，只需將您感興趣的結果行（在本例中爲唯一的公司名稱）複製並粘貼到新的列或表中即可獲得沒有數據透視的列附表。如果您想保留數據透視表，您可以右鍵單擊Grand Total並刪除它，並篩選列表以刪除(blank)條目。無論哪種方式，您現在都可以獲得沒有空白的唯一結果列表，並且它不需要任何公式或VBA，而且所需的資源相對較少（遠低於任何VBA或公式解決方案）。