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