Почему при Do - Loop приложение зависает

Private Sub SelectByFormat()
    Dim FirstCell As Range, FoundCell As Range
    Dim AllCells As Range
 
    If Val(Application.Version) < 10 Then
        MsgBox "Нужен Excel 2002 и выше"
        Exit Sub
    End If
'    ActiveWindow.DisplayGridlines = Not _
                    ActiveWindow.DisplayGridlines
    
    ActiveSheet.Cells.Delete
 
    Randomize Timer
    For i = 1 To 20
        For j = 1 To 10
            Cells(i, j).Value = Int((100 * Rnd()) + 1)
        Next j
    Next i
 
    [a3] = "aple": [b2] = "dog": [c5] = "floor"
    [d9] = "tobacco"
    Union([a3], [b2], [c5], [d9]).Font.Italic = True
 
    With Application.FindFormat
        .Interior.ColorIndex = xlNone '
        .Font.Bold = False
        .Font.Italic = True
    End With
    
    Set FirstCell = Cells.Find(What:="", SearchFormat:=True)
    
    If FirstCell Is Nothing Then
        MsgBox "Не найдено."
        Exit Sub
    End If
 
    Set AllCells = FirstCell
    Set FoundCell = FirstCell
 
    Do
        Set FoundCell = Cells.FindNext(After:=FoundCell)
        Set AllCells = Union(FoundCell, AllCells)
            If FoundCell.Address = _
                        FirstCell.Address Then Exit Do
    Loop
 
    AllCells.Select
        MsgBox " Нашли:    " & AllCells.Count
        
End Sub

    Set FirstCell = Cells.Find(What:="", SearchFormat:=True)
    
    If FirstCell Is Nothing Then
        MsgBox "не найдено."
        Exit Sub
    End If
 
    Set AllCells = FirstCell
    Set FoundCell = FirstCell
 
    Do
        Set FoundCell = Cells.Find(What:="", After:=FoundCell, SearchFormat:=True)
        Set AllCells = Union(FoundCell, AllCells)
            If FoundCell.Address = _
                        FirstCell.Address Then Exit Do
    Loop
 
    AllCells.Select
        MsgBox " Нашли:    " & AllCells.Count