合并Excel范围中的数据，删除空白和重复项

1 回答

• 5

  这是一种方法 .

  CODE (TRIED AND TESTED)

  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

  

  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
  

  HTH

  希德

  回复于 2024-04-24T10:32:49+08:00