Excel範囲内のデータをマージして空白と重複を削除する

Question

Excel内に複数の列幅と複数の行長のセル範囲があります。いくつかのセルは空白です。私は（VBAを使用して）非空白セルをリストにマージし、重複を削除し、アルファベット順にソートしたいと思います。例として

A 
B 
C 
D 
E 

次のソートされた出力が生成さ

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

：（ダッシュは、この質問の目的のために空のセルを指定する）この入力所与例えば

、範囲内のいくつかの行と列にすべての空のセルが含まれる場合があります。

Answer 1

これを行う方法の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 

SNAPSHOTS

フォロー

私はちょうど3行を追加することは、よりTになることに気づい彼のコードは上記のコードよりも高速です。

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

シド