Private pFuncs As WorksheetFunction
Private Type QueryType
    prevAddress As String
    prevRow As Long
    hasMerge As Boolean
End Type

Private Type QueryResultType
    signAddress As String
    isMerged As Boolean
End Type

Public Sub FormatNumbers()
    Dim vData, i As Long, t As Single, vCount As Long
    Dim formats(0 To 3) As String, vSign As Long
    Dim addresses(0 To 3) As QueryType, queryResult As QueryResultType
    Dim signAddress As String, curAddress As String
    t = Timer
    formats(0) = "0"
    formats(1) = "0,К"
    formats(2) = "0,,М"
    formats(3) = "0,,,В"
    
    addresses(0).prevRow = -1
    addresses(1).prevRow = -1
    addresses(2).prevRow = -1
    addresses(3).prevRow = -1
    
    vData = Range("B2:B540000").Value
    Set pFuncs = Application.WorksheetFunction
    For i = 1 To UBound(vData)
        vSign = getSign(vData(i, 1))
        curAddress = "B" & CStr(i + 1)
        queryResult = GetQueryResult(i, curAddress, addresses(vSign))
        If Len(queryResult.signAddress) > 255 Then
            vCount = vCount + 1
            Range(addresses(vSign).prevAddress).NumberFormat = formats(vSign)
            addresses(vSign).hasMerge = False
            addresses(vSign).prevAddress = curAddress
        Else
            addresses(vSign).hasMerge = queryResult.isMerged
            addresses(vSign).prevAddress = queryResult.signAddress
        End If
        addresses(vSign).prevRow = i
    Next
    For i = 0 To 3
        If addresses(i).prevAddress <> "" Then
            vCount = vCount + 1
            Range(addresses(i).prevAddress).NumberFormat = formats(i)
        End If
    Next
    Debug.Print (Timer - t) & " count: " & vCount
End Sub

Private Function GetQueryResult(curRow As Long, curAdddress As String, ByRef query As QueryType) As QueryResultType
    Dim result As QueryResultType, pos As Long
    If curRow - query.prevRow = 1 Then
        result.isMerged = True
        If query.hasMerge Then
            pos = InStrRev(query.prevAddress, ":")
            result.signAddress = Mid$(query.prevAddress, 1, pos) & curAdddress
        Else
            result.signAddress = query.prevAddress & ":" & curAdddress
        End If
    Else
        result.isMerged = False
        If query.prevAddress = "" Then
            result.signAddress = curAdddress
        Else
            result.signAddress = query.prevAddress & "," & curAdddress
        End If
    End If
    GetQueryResult = result
End Function

Private Function getSign(ByVal forValue As Double) As Long
    forValue = Abs(forValue)
    If forValue < 1# Then
        getSign = 0
    Else
        getSign = CLng(pFuncs.RoundDown(pFuncs.Log10(forValue), 0)) \ 3
    End If
End Function

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
'====================================================================================================