在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

西特