Function getVisibleTextInCell(rngSource As Range, strSource As String) As String

    Static wbkTest  As Workbook
    Static rngTest  As Range
    
    Dim varTest     As Variant
    Dim posOld      As Integer
    Dim posNew      As Integer
    Dim iter        As Integer
    Const iterMax   As Integer = 20
    
    If rngTest Is Nothing Then
        'создаем невидимую книгу с тестовым диапазоном (сохраняются между вызовами поскольку Static)
        With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
        Set wbkTest = Application.Workbooks.Add
        wbkTest.Windows(1).Visible = False
        Set rngTest = wbkTest.Worksheets(1).Range("A1")
        With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
    End If
    
    If strSource = "" Then
        'пустая строка уничтожает статические книгу и диапазон (в конце работы)
        Set rngTest = Nothing
        wbkTest.Close False
        Set wbkTest = Nothing
        Exit Function
    End If
    
    rngTest.WrapText = False
    rngTest.Font.Name = rngSource.Font.Name
    rngTest.Font.Size = rngSource.Font.Size
       
    '"грубая настройка"
    'подгоняем длину строки
    posNew = Len(strSource)
    Do
        iter = iter + 1
        posOld = posNew
        rngTest.Value = Left(strSource, posNew)
        rngTest.EntireColumn.AutoFit
        posNew = rngSource.Width / rngTest.Width * posOld
    Loop Until posNew = posOld Or iter = iterMax
    
    If rngTest.Width > rngSource.Width Then
        '"тонкая настройка"
        'переходим на посимвольное отщипывание с конца (если надо)
        iter = 0
        Do
            iter = iter + 1
            posNew = posNew - 1
            rngTest.Value = Left(strSource, posNew)
            rngTest.EntireColumn.AutoFit
        Loop Until rngTest.Width <= rngSource.Width Or iter = iterMax
    End If

    wbkTest.Saved = True 'чтобы невидимая книга не просила о сохранении
    getVisibleTextInCell = Left(strSource, posNew) 'для мелкого шрифта вполне можно добавить символ, т.е. posNew + 1
    
End Function