Option Explicit
'David McRitchie
'html http://www.mvps.org/dmcritchie/excel/delempty.htm
'code http://www.mvps.org/dmcritchie/excel/code/delempty.txt
Sub del_COLA_empty()
'D McRitchie http://www.mvps.org/dmcritchie/excel/delempty.htm 2004-01-10
'based on Matt Neuburg, PhD http://www.tidbits.com/matt Aug 3, 1998
'Loop required due to MS KB http://support.microsoft.com/?kbid=832293
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
i = Cells.SpecialCells(xlCellTypeLastCell).Row
For i = i To 1 Step -8000
On Error Resume Next 'in case there are no blanks
Range(Cells(Application.WorksheetFunction.Max(1, i - 7999), 1), _
Cells(Application.WorksheetFunction.Max(i, 1), 1)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Next i
Application.Calculation = xlCalculationAutomatic 'pre XL97 xlManual
Application.ScreenUpdating = True
ActiveSheet.UsedRange 'Resets UsedRange for Excel 97
End Sub
Public Sub Allsheets_Delete_Rows_Empty_in_column_A()
Application.Calculation = xlManual 'xl97 up use xlCalculationManual
Application.ScreenUpdating = False
Dim csht As Long 'modified 2004-Oct from del_COLA_empty
Dim rng As Range, ix As Long
For csht = 1 To ActiveWorkbook.Sheets.Count 'worksheet or sheets
Set rng = Intersect(Worksheets(csht).Range("A:A"), _
Worksheets(csht).UsedRange)
For ix = rng.Count To 1 Step -1
If Trim(Replace(rng.Item(ix).Text, _
Chr(160), Chr(32))) = "" Then
rng.Item(ix).EntireRow.Delete
End If
Next
done:
Next csht
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic 'xl97 up use xlCalculationAutomatic
End Sub
Sub SpecialCells_Coloring()
'demonstrates failure if more than 8192 cells selected by specialcells
'see MS KB http://support.microsoft.com/?kbid=832293
Dim rng As Range, cnt(5) As Long
Set rng = ActiveSheet.UsedRange
Cells.Interior.ColorIndex = xlNone
On Error Resume Next
rng.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 36
rng.SpecialCells(xlCellTypeConstants, xlTextValues).Interior.ColorIndex = 37
rng.SpecialCells(xlCellTypeConstants, xlNumbers).Interior.ColorIndex = 38
rng.SpecialCells(xlCellTypeFormulas, xlTextValues).Interior.ColorIndex = 39
rng.SpecialCells(xlCellTypeFormulas, xlNumbers).Interior.ColorIndex = 40
cnt(1) = rng.SpecialCells(xlCellTypeBlanks).Count
cnt(2) = rng.SpecialCells(xlCellTypeConstants, xlTextValues).Count
cnt(3) = rng.SpecialCells(xlCellTypeConstants, xlNumbers).Count
cnt(4) = rng.SpecialCells(xlCellTypeFormulas, xlTextValues).Count
cnt(5) = rng.SpecialCells(xlCellTypeFormulas, xlNumbers).Count
On Error GoTo 0
If cnt(1) + cnt(2) + cnt(3) + cnt(4) + cnt(5) <> rng.Count Then
MsgBox "Results probably in error, including these numbers, " & _
"see MS KB http://support.microsoft.com/?kbid=832293 " _
& Chr(10) & "Blanks = " & cnt(1) _
& Chr(10) & "Text Constants = " & cnt(2) _
& Chr(10) & "Number Constants = " & cnt(3) _
& Chr(10) & "Text from Formulas = " & cnt(4) _
& Chr(10) & "Numbers from Formulas = " & cnt(5) _
& Chr(10) & "actual cells in used area = " & rng.Count
End If
End Sub
'=====================================
Sub DelCellsUp()
'David McRitchie 07/17/1998 revised 2002-01-17
' http://www.mvps.org/dmcritchie/excel/delempty.htm
'Delete Empty Cells and cells with only spaces in range
' and move cells up from below even if not in range
'Will process single range of one or more columns
'Will not remove cells with formulas
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim rng As Range, ix As Long
Set rng = Intersect(Selection, ActiveSheet.UsedRange)
If rng Is Nothing Then
MsgBox "nothing in Intersected range to be checked/removed"
GoTo done
End If
For ix = rng.Count To 1 Step -1 'CHR(160) is non-breaking space
If Len(Trim(Replace(rng.Item(ix).Formula, Chr(160), ""))) _
= 0 Then rng.Item(ix).Delete (xlUp)
Next
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub DelEmpty()
'David McRitchie 08/08/1998
' http://www.mvps.org/dmcritchie/excel/excel.htm
'Delete Empty Cells and move cells up from below even
'if not in range. Will process ranges of one or more columns
Application.ScreenUpdating = False
Dim ix As Long
For ix = Selection.Count To 1 Step -1
If Selection.Item(ix) = x1Blanks Then _
Selection.Item(ix).Delete (xlUp)
Next ix
Application.ScreenUpdating = True
End Sub
Sub DelTrailingChr()
'David McRitchie 2002-03-11
End Sub
Sub DelEvenRows()
'David McRitchie 2002-03-11 mod 2002-06-26
'Delete Even numbered rows from the bottom
Application.ScreenUpdating = False
Dim ix As Long
ix = Cells.SpecialCells(xlLastCell).Row - _
Cells.SpecialCells(xlLastCell).Row Mod 2
For ix = ix To 2 Step -2
Rows(ix).Delete
Next ix
Application.ScreenUpdating = True
End Sub
Sub DelEmpty2()
'Matt Neuburg, PhD http://www.tidbits.com/matt Aug 3, 1998
Selection.SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)
End Sub
Sub DelRows_on_EmptyA()
'modified from Matt Neuburg, PhD http://www.tidbits.com/matt Aug 3, 1998
On Error Resume Next '-- in case there are no empty cells in usedrange
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete (xlShiftUp)
End Sub
Sub DelEmptyRows()
Dim i As Long, iLimit As Long 'updated for XL2003 2006-01-31
iLimit = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
For i = iLimit To 1 Step -1
If Application.CountA(Cells(i, 1).EntireRow) = 0 Then
Cells(i, 1).EntireRow.Delete
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
iLimit = ActiveSheet.UsedRange.Rows.Count 'attempt to fix lastcell
ActiveWorkbook.Save
End Sub
Sub DelEmptyColumns()
Dim chkRange As Range, i As Long, iLimit As Long
Set chkRange = Rows("1:1").SpecialCells(xlCellTypeBlanks)
iLimit = chkRange.Count
If iLimit = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
For i = iLimit To 1 Step -1
If Application.CountA(chkRange.Item(i).EntireColumn) = 0 _
Then chkRange.Item(i).EntireColumn.Delete
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
iLimit = ActiveSheet.UsedRange.Rows.Count 'attempt to fix lastcell
iLimit = ActiveSheet.UsedRange.Columns.Count 'attempt to fix lastcell
ActiveWorkbook.Save
End Sub
Sub DeleteCells4()
'modified from http://support.microsoft.com/support/kb/articles/Q213/5/44.asp
'see http://www.mvps.org/dmcritchie/excel/delempty.htm
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim rng As Range, i As Long
Dim xx As String
'Set the range to evaluate to rng.
'-----Set rng = Range("A1:A10")
Set rng = Intersect(Selection, Range("A:A"), ActiveSheet.UsedRange)
'Loop backwards through the rows
'in the range that you want to evaluate.
'For i = rng.Rows.Count To 1 Step -1
If rng Is Nothing Then
MsgBox "nothing in Intersected range to be checked," _
& Chr(10) & "there is an internal range(""a:a"")"
GoTo done
End If
For i = rng.Count To 1 Step -1
'If cell i in the range contains an "x", delete the entire row.
If rng.Cells(i).Value = "x" Then rng.Cells(i).EntireRow.Delete
' xx = Trim(rng.Cells(i).Value)
' If xx = "x" Or xx = "y" Or xx = "z" Or _
' xx >= "a" And xx <= "g" Or xx = "abc" Then
' rng.Cells(i).EntireRow.Delete
' End If
Next
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub DelCellsValue()
'From: Dana DeLouis
'Newsgroups: microsoft.public.Excel.programming
'Sent: Thursday, July 27, 2000 4:40 PM
'Subject: Re: VBA clean up in worksheet/more than one variable
'news:eDUwcrA#$GA.242@cppssbbsa02.microsoft.com...
Dim s As Variant
Dim rng As Range
On Error Resume Next
With ActiveSheet.UsedRange
For Each s In Array("End-of", "x", String(15, "-"))
.Replace _
What:=s, _
replacement:="TRUE", _
lookat:=xlWhole, _
MatchCase:=False
Next
Set rng = Cells.SpecialCells(xlConstants, xlLogical).EntireRow
' Remove overlapping areas for this to work.
'Set Rng = Application.Intersect(Rng) ', Rng)
rng.Delete
End With
ActiveSheet.UsedRange
End Sub
'=========================================================
Sub DeleteRowsRedInColA()
'David McRitchie 2002-01-17
' http://www.mvps.org/dmcritchie/excel/colors.htm
'Will not find color due to Conditional Formatting
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim rng As Range, ix As Long
Set rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)
If rng Is Nothing Then
MsgBox "nothing in Intersected range to be checked/removed"
GoTo done
End If
For ix = rng.Count To 1 Step -1
If rng.Item(ix).Interior.ColorIndex = 3 Then
rng.Item(ix).EntireRow.Delete
End If
Next
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub DeleteRowsThatLookEmptyinColA()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim rng As Range, ix As Long
Set rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)
For ix = rng.Count To 1 Step -1
If Trim(Replace(rng.Item(ix).Text, _
Chr(160), Chr(32))) = "" Then
rng.Item(ix).EntireRow.Delete
End If
Next
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Public Sub RemoveBlankColumns()
'Josh Kramer, joshk6@my-deja.com 2000-08-22, programming
'changed name from ClearBlankColumn()
'sugg. improvement might be to have a selection on
' row 1, but check the entire column
Dim WS As Worksheet
Set WS = ActiveSheet
Dim col As Range
Dim nonblank As Long
For Each col In WS.UsedRange.Columns
nonblank = 0
With col
On Error Resume Next
nonblank = .SpecialCells(xlCellTypeFormulas).Cells.Count
nonblank = .SpecialCells(xlCellTypeConstants).Cells.Count
End With
If nonblank > 0 Then
col.EntireColumn.Delete
End If
Next col
End Sub
Sub DEL95HTMLemptyCellsL()
'David McRitchie, 2002-08-24, Worksheet Functions
' http://google.com/groups?threadm=%23GK09%248SCHA.4304%40tkmsftngp08
' Move cells up into empty cell above if Column A cell
' on line to be moved up is empty.
Application.ScreenUpdating = False
Application.Calculation = xlManual '--Excel 95
Dim Rcnt As Long, Ccnt As Long, R As Long, c As Long
Dim CurrCell As Range
On Error Resume Next
Selection.Replace What:=Chr(160), replacement:=Chr(32), _
lookat:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
Rcnt = Cells.SpecialCells(xlLastCell).Row
Ccnt = Cells.SpecialCells(xlLastCell).Column
For R = Rcnt To 2 Step -1
If IsEmpty(Cells(Rcnt, 1)) Then
For c = 1 To Ccnt
If Not IsEmpty(Cells(R, c)) Then
If Not IsEmpty(Cells(R - 1, c)) Then GoTo notthis
End If
Next c
For c = 1 To Ccnt
If Not IsEmpty(Cells(R, c)) Then
Cells(R - 1, c) = Cells(R, c)
End If
Next c
' MsgBox "ready to delete row " & r
Cells(R, 1).EntireRow.Delete
notthis:
End If
Next R
Application.Calculation = xlAutomatic '--Excel 95
Application.ScreenUpdating = True
End Sub
Sub DEL95HTML_BR()
'David McRitchie, 2003-11-03 based on 2002-08-24, Worksheet Functions
' http://google.com/groups?threadm=%23GK09%248SCHA.4304%40tkmsftngp08
' Move cells up into empty cell above if Column A cell
' on line to be moved up is empty.
Application.ScreenUpdating = False
Application.Calculation = xlManual '--Excel 95
Dim Rcnt As Long, Ccnt As Long, R As Long, c As Long
Dim CurrCell As Range
On Error Resume Next
Selection.Replace What:=Chr(160), replacement:=Chr(32), _
lookat:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
'-- add for HTML table creation with
Selection.Replace What:=Chr(10), replacement:="
", _
lookat:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
Rcnt = Cells.SpecialCells(xlLastCell).Row
Ccnt = Cells.SpecialCells(xlLastCell).Column
For R = Rcnt To 2 Step -1
If IsEmpty(Cells(R, 1)) Then
For c = 1 To Ccnt
If Not IsEmpty(Cells(R, c)) Then
If Not IsEmpty(Cells(R - 1, c)) Then
Cells(R - 1, c) = Cells(R - 1, c) & _
Chr(13) & "
" & Cells(R, c)
Else
Cells(R - 1, c) = Cells(R, c)
End If
End If
Next c
Cells(R, 1).EntireRow.Delete
End If
Next R
Application.Calculation = xlAutomatic '--Excel 95
Application.ScreenUpdating = True
End Sub
Sub del_rows_with_bold()
' David McRitchie, 2005-09-01
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Rcnt As Long, Ccnt As Long, R As Long, c As Long
Dim CurrCell As Range
On Error Resume Next
Rcnt = Cells.SpecialCells(xlLastCell).Row
Ccnt = Cells.SpecialCells(xlLastCell).Column
For R = Rcnt To 2 Step -1
For c = 1 To Ccnt
If Cells(R, c).Font.Bold And Not IsEmpty(Cells(R, c)) Then
'-- Must be bold and have content
Cells(R, c).EntireRow.Delete
GoTo next_r
End If
Next c
next_r:
Next R
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub