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 <dana2@email.msn.com>
'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 <BR>
    Selection.Replace What:=Chr(10), replacement:="<br>", _
        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) & "<BR>" & 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