Объединение данных в диапазоне Excel, удаление пробелов и дубликатов

Question

У меня есть диапазон ячеек в Excel, который имеет ширину более одного столбца и длину более одного ряда. Некоторые клетки пустые. Я хотел бы объединить (используя VBA) непустые ячейки в список, удалить дубликаты и отсортировать по алфавиту.

Например, с учетом этого ввода (где тире обозначает пустую ячейку для целей этого вопроса):

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

Будет получен следующий отсортированный вывод:

A
B
C
D
E

Как показывает пример ввода, некоторые строки и столбцы в диапазоне могут содержать все пустые ячейки.

Answer 1

Вот один из способов сделать это.

КОД (ПРОВЕРЕНО И ИСПЫТАНО)

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

ИЛЛЮСТРАЦИИ

Followup

Я только что понял, что добавление еще 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

НТН

Sid