在Excel範圍內合併數據，刪除空白和重複

Question

我有一個單元格範圍在Excel中，多列寬和多行長。有些單元格是空白的。我想合併（使用VBA）非空白單元格到列表中，刪除重複，並按字母順序排序。

例如，給定該輸入（其中a破折號表示爲這個問題爲目的的空單元）：

- - A D - 
C - - A - 
- - B - D 
- - - - - 
A - - E - 

以下排序輸出產生：

A 
B 
C 
D 
E 

如示例輸入顯示，範圍中的某些行和列可能包含所有空白單元格。

Answer 1

這是一種方法。

CODE（試驗和測試）

Option Explicit 

Sub Sample() 
    Dim ws As Worksheet 
    Dim LastRow As Long, lastCol As Long, i as Long 
    Dim Rng As Range, aCell As Range 
    Dim MyCol As New Collection 

    '~~> Change this to the relevant sheet name 
    Set ws = Sheets("Sheet21") 

    With ws 
     LastRow = .Cells.Find(What:="*", After:=.Range("A1"), _ 
     Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _ 
     SearchDirection:=xlPrevious, MatchCase:=False).Row 

     lastCol = .Cells.Find(What:="*", After:=.Range("A1"), _ 
     Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, _ 
     SearchDirection:=xlPrevious, MatchCase:=False).Column 

     Set Rng = .Range("A1:" & Split(.Cells(, lastCol).Address, "$")(1) & LastRow) 

     'Debug.Print Rng.Address 
     For Each aCell In Rng 
      If Not Len(Trim(aCell.Value)) = 0 Then 
       On Error Resume Next 
       MyCol.Add aCell.Value, """" & aCell.Value & """" 
       On Error GoTo 0 
      End If 
     Next 

     .Cells.ClearContents 

     For i = 1 To MyCol.Count 
      .Range("A" & i).Value = MyCol.Item(i) 
     Next i 

     '~~> OPTIONAL (In Case you want to sort the data) 
     .Columns(1).Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _ 
     OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
     DataOption1:=xlSortNormal 
    End With 
End Sub 

快照

隨訪

我剛剛意識到加入3個線條更使得噸他的代碼甚至比上面的代碼更快。

Option Explicit 

Sub Sample() 
    Dim ws As Worksheet 
    Dim LastRow As Long, lastCol As Long, i As Long 
    Dim Rng As Range, aCell As Range, delRange As Range '<~~ Added This 
    Dim MyCol As New Collection 

    '~~> Change this to the relevant sheet name 
    Set ws = Sheets("Sheet1") 

    With ws 
     '~~> Get all the blank cells 
     Set delRange = .Cells.SpecialCells(xlCellTypeBlanks) '<~~ Added This 

     '~~> Delete the blank cells 
     If Not delRange Is Nothing Then delRange.Delete '<~~ Added This 

     LastRow = .Cells.Find(What:="*", After:=.Range("A1"), _ 
     Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _ 
     SearchDirection:=xlPrevious, MatchCase:=False).Row 

     lastCol = .Cells.Find(What:="*", After:=.Range("A1"), _ 
     Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, _ 
     SearchDirection:=xlPrevious, MatchCase:=False).Column 

     Set Rng = .Range("A1:" & Split(.Cells(, lastCol).Address, "$")(1) & LastRow) 

     'Debug.Print Rng.Address 
     For Each aCell In Rng 
      If Not Len(Trim(aCell.Value)) = 0 Then 
       On Error Resume Next 
       MyCol.Add aCell.Value, """" & aCell.Value & """" 
       On Error GoTo 0 
      End If 
     Next 

     .Cells.ClearContents 

     For i = 1 To MyCol.Count 
      .Range("A" & i).Value = MyCol.Item(i) 
     Next i 

     '~~> OPTIONAL (In Case you want to sort the data) 
     .Columns(1).Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _ 
     OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
     DataOption1:=xlSortNormal 
    End With 
End Sub 

HTH

西特