删除多行多列中的空单元格并重新整理数据

Sub DeleteEmpty()
 Dim r As Long, c As Long
 Dim rLast As Range, rData As Range, rEnd As Range
 
 Application.ScreenUpdating = False
 
 With ActiveSheet
   Set rLast = .Cells.Find(What:="*", _
    After:=Range("A1"), _
    LookAt:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False)
 
   Set rData = Range(.Cells(1, 1), rLast)
 
   With rData
   '删除空字符串使之成为真的空单元格
     .Replace What:="", Replacement:="###", LookAt:=xlPart
     .Replace What:="###", Replacement:="", LookAt:=xlPart
 
   '删除空列
     For c = .Columns.Count To 1 Step -1
       If Application.WorksheetFunction.CountBlank(.Columns(c)) = .Rows.Count Then
         .Columns(c).Delete
       End If
     Next c
 
   '删除空行
     For r = .Rows.Count To 1 Step -1
       If Application.WorksheetFunction.CountBlank(.Rows(r)) = .Columns.Count Then
         .Rows(r).Delete
       End If
     Next r
   End With
 
   Set rLast = .Cells.Find(What:="*", _
     After:=Range("A1"), _
     LookAt:=xlPart, _
     LookIn:=xlFormulas, _
     SearchOrder:=xlByRows, _
     SearchDirection:=xlPrevious, _
     MatchCase:=False)
 
   Set rData = Range(.Cells(1, 1), rLast)
   '向上移动数据
   For c = 1 To rData.Columns.Count
     Set rEnd = rData.Columns(c).Cells(.Rows.Count, c).End(xlUp)
 
     On Error Resume Next
     Range(.Cells(1, c), rEnd).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
     On Error GoTo 0
   Next c
 End With
 Application.ScreenUpdating = False
End Sub

Sub test()
 Dim rng As Range, rCell As Range, var As Variant, x As Long, rCount As Long
 
 Set rng = Sheet1.UsedRange
 With rng
   .Replace "", "|"
   .Replace "|", ""
   Set rng = .SpecialCells(xlCellTypeConstants)
   rCount = .Cells.Count
 End With
 ReDim var(rCount - 1)
 For Each rCell In rng
   var(x) = rCell
   x = x + 1
 Next rCell
 Range("A1").Resize(rCount) =
 Application.Transpose(var)
End Sub

Sub test()
 Dim rng As Range, var As Variant, oVar() As Variant
 Dim r As Long, c As Long, z As Long
 
 Set rng = Sheet1.UsedRange
 ReDim oVar(Application.CountIf(rng, "?*") - 1)
 var = rng.Value
 For c = 1 To UBound(var, 2)
   For r = 1 To UBound(var)
     If Len(var(r, c)) > 0 Then
       oVar(z) = var(r, c): z = z + 1
     End If
   Next r
 Next c
 Range("A1").Resize(UBound(oVar) + 1) = Application.Transpose(oVar)
End Sub