在Excel范围合并数据，删除空白和重复

我有一个Excel的单元格范围是多列宽和多行长。 一些单元格是空白的。 我想合并（使用VBA）的非空白单元格到列表中，删除重复，并按字母顺序sorting。

例如，给定这个input（为了这个问题，一个破折号指定一个空单元格）：

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

生成以下sorting的输出：

 A B C D E 

如示例input所示，范围中的某些行和列可能包含所有空白单元格。

Answer 1

这是一个办法。

代码（试验和testing）

 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

希德