Sub usuwaj()
Dim zakres As Range, wiersz As Integer, kolumna As Integer
'wpisz właściwy zakres
Set zakres = Range("A1:H100")

For wiersz = 1 To zakres.Rows.Count
For kolumna = zakres.Columns.Count To 1 Step -1
If zakres(wiersz, kolumna) = "" Then zakres(wiersz, kolumna).Delete Shift:=xlToLeft
Next kolumna
Next wiersz
Set zakres = Nothing
End Sub

Sub DelCellsUp()
  'David McRitchie 1998-07-17 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 DEL95HTMLemptyCells()
  'David McRitchie, 2002-08-24, Worksheet Functions
  ' Move cells up into empty cell below 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
          Cells(r, 1).EntireRow.Delete
notthis:
       End If
    Next r
    Application.Calculation = xlAutomatic  '--Excel 95
    Application.ScreenUpdating = True
  End Sub