I am running a code that reads cell strings and then evaluates its width using a slightly modified solution taken from here

vb macro string width in pixel

The code does several things with the cell contents, but I manage to isolate the problem. When I run the code with, say 8000 cells, the code runs OK, and I get the width of the string in each cell and then the reminder of the code is executed. However, as the number of cells increases, the code hangs the EXCEL application. Sometimes, it manages to reach the end of the routine, but the application is already hanged, and the only solution is to kill EXCEL from Task Manager.

I believe I am having an issue with the memory, so I tried to clean up the clipboard both in the middle of the cycle (before 9000 cells, at least), but it did not help.
The computer is running Win11, Office 365+ and 16 GB of memory.
Can anyone help?
Here is the code.

'
'   For procedures
'       GetStringPixelWidth
'       GetStringPixelheight
'       GetLabelSize
'   Please see references in /questions/5012465/vb-macro-string-width-in-pixel#comment5603926_5012465
'
'API Declares
'
Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "User32" () As LongPtr
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As LongPtr) As Long
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As LongPtr, ByVal nHeight As LongPtr) As Long
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal cbString As LongPtr, lpSize As FNTSIZE) As Long
Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" (ByVal nNumber As LongPtr, ByVal nNumerator As LongPtr, ByVal nDenominator As LongPtr) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nIndex As LongPtr) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long

Private Const LOGPIXELSY As Long = 90

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

Private Type FNTSIZE
    cx As Long
    cy As Long
End Type

Sub textsize()
'
    Dim frow As Long, lrow As Long, irow As Long, iStop As Long, columnpixels As Long
    Dim rng As Range, cell As Range
'
    Dim FontName As String
    Dim FontSize As Single
    Dim FontBold As Boolean
    Dim sText As String
    Dim stringWidth As Single
'
'
    Application.ScreenUpdating = False
    frow = 4
    'lrow = 11701
    lrow = 9000
'
    FontName = "Verdana"
    FontSize = 11
    FontBold = False
'
'
    For irow = frow To lrow
'
        Set rng = Range("A" & irow & ":D" & irow)
        Set cell = Range("B" & irow)
        
        With cell
            If .Value2 <> "" Then
'
                With .font
                    If .Name <> FontName Then rng.Rows(irow - 3).font.Name = FontName
                    If .Size <> FontSize Then rng.Rows(irow - 3).font.Size = FontSize
                    If (.Bold) Then
                        If Len(cell.Offset(0, -1).Value2) = 4 Then
                            FontBold = True
                            rng.Rows(irow - 3).font.Bold = True
                        Else
                            FontBold = False
                            rng.Rows(irow - 3).font.Bold = False
                        End If
                    End If
                End With
'
                sText = .Value2
'                                                               '
                stringWidth = GetStringPixelWidth(sText, FontName, FontSize, FontBold)
'
            End If
        End With
        Debug.Print irow, stringWidth
    Next irow
'
    DoEvents
    Application.CutCopyMode = False
    Call ClearClipboard
'
    Application.ScreenUpdating = True
'
End Sub
'

Public Function ClearClipboard()
  OpenClipboard (0&)
  EmptyClipboard
  CloseClipboard
End Function
'
'
Public Function GetStringPixelWidth(text As String, FontName As String, FontSize As Single, _
                                    Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer

    Dim font As New StdFont
    Dim sz As FNTSIZE
    font.Name = FontName
    font.Size = FontSize
    font.Bold = isBold
    font.Italic = isItalics

    sz = GetLabelSize(text, font)
    GetStringPixelWidth = sz.cx

End Function
'
'
Public Function GetStringPixelHeight(text As String, FontName As String, FontSize As Single, _
                                     Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer
'
    Dim font As New StdFont
    Dim sz As FNTSIZE
    font.Name = FontName
    font.Size = FontSize
    font.Bold = isBold
    font.Italic = isItalics
    
    sz = GetLabelSize(text, font)
    GetStringPixelHeight = sz.cy

End Function
'
'
Private Function GetLabelSize(text As String, font As StdFont) As FNTSIZE
    Dim tempDC As Long
    Dim tempBMP As Long
    Dim f As Long
    Dim lf As LOGFONT
    Dim textsize As FNTSIZE

    ' Create a device context and a bitmap that can be used to store a
    ' temporary font object
    tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
    tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)

    ' Assign the bitmap to the device context
    DeleteObject SelectObject(tempDC, tempBMP)

    ' Set up the LOGFONT structure and create the font
    lf.lfFaceName = font.Name & Chr$(0)
    '
    Dim TempDC2 As Long
    TempDC2 = GetDC(0)
    '
    lf.lfHeight = -MulDiv(font.Size, GetDeviceCaps(GetDC(0), 90), 72) 'LOGPIXELSY
    lf.lfItalic = font.Italic
    lf.lfStrikeOut = font.Strikethrough
    lf.lfUnderline = font.Underline
    If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
    f = CreateFontIndirect(lf)

    ' Assign the font to the device context
    DeleteObject SelectObject(tempDC, f)

    ' Measure the text, and return it into the textSize SIZE structure
    GetTextExtentPoint32 tempDC, text, Len(text), textsize

    ' Clean up (very important to avoid memory leaks!)
    DeleteObject f
    DeleteObject tempBMP
    DeleteDC tempDC
    DeleteDC TempDC2
  '
  ' Return the measurements
    GetLabelSize = textsize

End Function```