Excellent... It really helped me.. thnks DonkeyOteMichael - try this:
n = Worksheets("Sheet1").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
Dim lRealLastRow, lRealLastCol As Long
lRealLastRow = Cells.Find("*", Range("A1"), xlValues, , xlByRows, xlPrevious).Row
lRealLastCol = Cells.Find("*", Range("A1"), xlValues, , xlByColumns, xlPrevious).Column
For i = 1 To lRealLastCol
If lRealLastRow - WorksheetFunction.CountBlank(Intersect(Columns(i), ActiveSheet.UsedRange)) <= 1 Then _
Columns(i).EntireColumn.Delete
Next i