[求助]如何用VBA判断空行并删除?[未解决-高手请进]

kowloon

空隔(space)視為空, 判斷及刪除空行

Sub DelEmptyRow()
endR = Cells.SpecialCells(xlLastCell).Row
endC = Cells.SpecialCells(xlLastCell).Column
For i = endR To 1 Step -1
If Application.CountA(Rows(i)) = 0 Then
Rows(i).EntireRow.Delete
Else
For j = 1 To endC
If Len(Trim(Cells(i, j))) > 0 Then GoTo 100
Next j
Rows(i).EntireRow.Delete
100:
End If
Next i
End Sub

請測試! 速度應不會太慢

是否放在Event, 自行決定

此題不適宜用End(xl..)

lindos

QUOTE:

以下是引用zjxia889在2008-2-2 14:30:06的发言：
Option Base 1
Sub 删除()
 Dim rng As Range
 Dim arr
 Dim k As Long, l%, m%
 Set rng = ActiveSheet.UsedRange
 arr = rng.Value
 m = UBound(arr, 2)
 ReDim Preserve arr(UBound(arr), m + 1)
 For k = 1 To UBound(arr)
   For l = 1 To m
     If Trim(arr(k, l)) = "" Then
          arr(k, m + 1) = arr(k, m + 1) + 1
     End If
   Next l
 Next k
 For k = UBound(arr) To 1 Step -1
   If arr(k, m + 1) = m Then
     Rows(rng.Row + k - 1).Delete
   End If
 Next k
End Sub

有错误:"下标越界"

fycwater

受教了！！学习

zjxia889

Option Base 1
要在第一行

zjxia889

要不这样?

Sub 删除()
 Dim rng As Range
 Dim arr
 Dim k As Long, l%, m%
 Set rng = ActiveSheet.UsedRange
 arr = rng.Value
 m = UBound(arr, 2)
 ReDim Preserve arr(1 to UBound(arr), 1 to m + 1)
 For k = 1 To UBound(arr)
   For l = 1 To m
     If Trim(arr(k, l)) = "" Then
          arr(k, m + 1) = arr(k, m + 1) + 1
     End If
   Next l
 Next k
 For k = UBound(arr) To 1 Step -1
   If arr(k, m + 1) = m Then
     Rows(rng.Row + k - 1).Delete
   End If
 Next k
End Sub

[此贴子已经被作者于2008-2-2 15:06:21编辑过]

lindos

QUOTE:

以下是引用zjxia889在2008-2-2 14:57:55的发言：
Option Base 1
要在第一行

谢谢, Option Base 1
可以了.

唯一的不足就是如果数据量大的话耗时很长.

如果加上禁止更新, 完成后再显示就好了.

可我不知道代码怎么写

fycwater

这样优化以下减少一次循环；

Sub 删除1()
 Dim rng As Range
 Dim arr
 Dim k As Long, l%, m%, mm%
 Set rng = ActiveSheet.UsedRange
 arr = rng.Value
 m = UBound(arr, 2)
mm = 1
 ReDim Preserve arr(UBound(arr), m + 1)
 For k = 1 To UBound(arr)
   For l = 1 To m
     If Trim(arr(k, l)) = "" Then
          arr(k, m + 1) = arr(k, m + 1) + 1
       
     End If
   Next l
   If arr(k, m + 1) = m Then
   Rows(rng.Row + k - mm).Delete
   mm = mm + 1
   End If
  
 Next k
 
End Sub

[此贴子已经被作者于2008-2-2 16:55:21编辑过]

fecmen

QUOTE:

以下是引用lindos在2008-2-2 15:04:58的发言：

谢谢, Option Base 1
可以了.

唯一的不足就是如果数据量大的话耗时很长.

如果加上禁止更新, 完成后再显示就好了.

可我不知道代码怎么写

看你会编VB！那么VBA自然也不在话下。那么多人给你出主意，有很多很不错！自己稍微修改一下就能满足自己的要求。

还要人把饭喂到你嘴巴里啊！高手们都很忙的！

[此贴子已经被作者于2008-2-2 15:43:48编辑过]

lindos

QUOTE:

以下是引用kowloon在2008-2-2 14:37:11的发言：

空隔(space)視為空, 判斷及刪除空行

Sub DelEmptyRow()
endR = Cells.SpecialCells(xlLastCell).Row
endC = Cells.SpecialCells(xlLastCell).Column
For i = endR To 1 Step -1
If Application.CountA(Rows(i)) = 0 Then
Rows(i).EntireRow.Delete
Else
For j = 1 To endC
If Len(Trim(Cells(i, j))) > 0 Then GoTo 100
Next j
Rows(i).EntireRow.Delete
100:
End If
Next i
End Sub

請測試! 速度應不會太慢

是否放在Event, 自行決定

此題不適宜用End(xl..)

谢谢, 在试.....

zjxia889

Sub 删除空行()
 Application.ScreenUpdating = False
 Dim rng As Range
 Dim arr
 Dim k As Long, l%, m%
 Set rng = ActiveSheet.UsedRange
 arr = rng.Value
 m = UBound(arr, 2)
 ReDim Preserve arr(1 To UBound(arr), 1 To m + 1)
 For k = UBound(arr) To 1 Step -1
   For l = 1 To m
     If Trim(arr(k, l)) = "" Then
          arr(k, m + 1) = arr(k, m + 1) + 1
     End If
   Next l
      If arr(k, m + 1) = m Then
     Rows(rng.Row + k - 1).Delete
   End If
 Next k
 Application.ScreenUpdating = True
End Sub