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

Private pFuncs As WorksheetFunction

Public Sub FormatNumbers()
    Dim vData, i As Long, t As Single
    Dim formats(0 To 3) As String, vSign As Long
    Dim addresses(0 To 3) As String, curAddress As String
    Dim signAddress As String
    t = Timer
    formats(0) = "0"
    formats(1) = "0,К"
    formats(2) = "0,,М"
    formats(3) = "0,,,В"
    
    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)
        signAddress = getSignAddress(curAddress, addresses(vSign))
        If Len(signAddress) > 255 Then
            Range(addresses(vSign)).NumberFormat = formats(vSign)
            addresses(vSign) = curAddress
        Else
            addresses(vSign) = signAddress
        End If
    Next
    For i = 0 To 3
        If addresses(i) <> "" Then Range(addresses(i)).NumberFormat = formats(i)
    Next
    Debug.Print Timer - t
End Sub

Function getSignAddress(ByVal curAddress As String, ByVal beforeAddresses As String) As String
    If beforeAddresses = "" Then
        getSignAddress = curAddress
    Else
        getSignAddress = beforeAddresses & "," & curAddress
    End If
End Function

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