Sub OldMacro()
Dim lLastRow As Long, i As Long
  lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
  Application.ScreenUpdating = False
  For i = lLastRow To 7 Step -1
     If Application.CountA(Rows(i)) = 0 Or Application.CountA(Rows(i)) = Null Or Len(Cells(i, 1)) = 0 Then Rows(i).Delete
  Next
  Application.ScreenUpdating = True
End Sub

Sub NewMacro()
Dim r As Long, rng As Range
    For r = 1 To ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
        If Application.CountA(Rows(r)) = 0 Then
            If rng Is Nothing Then Set rng = Rows(r) Else Set rng = Union(rng, Rows(r))
        End If
    Next r
    If Not rng Is Nothing Then rng.Delete
End Sub

Option Explicit
Sub BMK()
Dim cl As Range, v&
    For Each cl In Selection
        v = Abs(cl.Value2)
        If v > 999999999 Then cl.NumberFormat = "0,,,В":    GoTo nx
        If v > 999999 Then cl.NumberFormat = "0,,M":        GoTo nx
        If v > 999 Then cl.NumberFormat = "0,K"
nx: Next cl
End Sub

Option Explicit
'====================================================================================================
Sub Макрос2()
Dim cl As Range, x

    For Each cl In Range("B1:B10")
        x = cl.Value2
        If x < -1000000000 Then cl.NumberFormat = "0,,,В":  GoTo nx
        If x < -1000000 Then cl.NumberFormat = "0,,М":      GoTo nx
        If x < -1000 Then cl.NumberFormat = "0,К":          GoTo nx
        If x > 1000000000 Then cl.NumberFormat = "0,,,В":   GoTo nx
        If x > 1000000 Then cl.NumberFormat = "0,,М":       GoTo nx
        If x > 1000 Then cl.NumberFormat = "0,К":           GoTo nx
        If x < 0 Then cl.NumberFormat = "0"
nx:
     Next cl
End Sub

Option Explicit
'====================================================================================================
Sub Formatter()
Dim rng As Range, ar As Range
Dim dFrmt As New Dictionary
Dim x, arr, arrOne(1 To 1, 1 To 1)
Dim adr$, t!, v&, r&, c&, n&, AC&

t = Timer
Set rng = Range("B1:B10")   ' можно задать диапазон из нескольких областей

    For Each ar In rng.Areas
        arr = ar.Value2
        If Not IsArray(arr) Then arrOne(1, 1) = arr: arr = arr

        For c = 1 To UBound(arr, 2)
            For r = 1 To UBound(arr, 1)
                If Len(arr(r, c)) = 0 Then GoTo nx          ' если проверки не нужны, уберите, но время выполнения они заметно НЕ увеличивают
                If Not IsNumeric(arr(r, c)) Then GoTo nx    '
    
                v = Abs(arr(r, c)): n = n + 1               ' значение по-модулю с округлением до целых. Увеличиваем счётчик участвующих ячеек
                adr = rng(r, c).Address(0, 0, xlA1)         ' адрес очередной ячейки вида "A1"
    
                If v < 1000 Then FillDic dFrmt, "0", adr:           GoTo nx
                If v < 1000000 Then FillDic dFrmt, "0,K", adr:      GoTo nx
                If v < 1000000000 Then FillDic dFrmt, "0,,M", adr:  GoTo nx
                FillDic dFrmt, adr, "0,,,B"
nx:         Next r
        Next c
    Next ar

If n = 0 Then MsgBox "Nothing to Format …", vbInformation, Format$(Timer - t, "0.00 sec"): Exit Sub

Application.ScreenUpdating = False: r = 0
AC = Application.Calculation: Application.Calculation = xlCalculationManual

    For Each x In dFrmt.Keys
        r = r + 1
        For Each arr In FILE_RangesFromAddress(Join(dFrmt(x), ","), rng.Parent)
            arr.NumberFormat = x
        Next arr
    Next x

Application.ScreenUpdating = True
Application.Calculation = AC

MsgBox "Formats used:" & vbTab & r & " out of 4" & vbLf & "Cells fomatting: " & vbTab & Format$(n, "# ### ### ### ###"), vbInformation, Format$(Timer - t, "0.00 sec")
End Sub
'====================================================================================================
Private Sub FillDic(dic As Dictionary, iKey$, iItem$)
Dim x

    If dic.Exists(iKey) Then
        x = dic(iKey)
        ReDim Preserve x(UBound(x) + 1)
        x(UBound(x)) = iItem
        dic(iKey) = x
    Else
        dic.Add iKey, Array(iItem)
    End If
End Sub
'====================================================================================================
'====================================================================================================
' Функция принимает лист и строку адресов с этого листа в виде одномерного массива, а возвращает массив "укрупнённых" адресов
' Если лист не передан, то принимается активный лист
'====================================================================================================
Function FILE_RangesFromAddress(ByVal txAdr$, Optional sh As Worksheet) As Range()
Dim arr() As Range
Dim l&, n&, i&, p&, m&

If sh Is Nothing Then Set sh = ActiveSheet
If InStr(txAdr, "$") Then txAdr = Replace$(txAdr, "$", "")
l = Len(txAdr): If l < 256 Then ReDim arr(0): Set arr(0) = sh.Range(txAdr): GoTo fin
m = l - 256

ReDim arr(l \ 200): n = -1
    Do
        i = InStrRev(txAdr, ",", p + 256)
        n = n + 1: Set arr(n) = sh.Range(Mid$(txAdr, p + 1, i - p - 1))
        p = i

        If p > m Then
            n = n + 1: Set arr(n) = sh.Range(Right$(txAdr, l - p))
            ReDim Preserve arr(n): GoTo fin
        End If
    Loop

fin: FILE_RangesFromAddress = arr
End Function
'====================================================================================================