Почему при 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

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
    Dim StrSearsh As String
    StrSearsh = InputBox("Введите значение", "", "floor")
    If StrSearsh = "" Then MsgBox "Нет значения поиска": Exit Sub
    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:=StrSearsh, SearchFormat:=True)
    
    If FirstCell Is Nothing Then
        MsgBox "Выражение   " & StrSearsh & "   не найдено."
        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 FoundCell = Cells.Find(What:="", After:=ActiveCell, SearchFormat:=True)

    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

Private Sub SelectByFormat()
    Dim FirstCell As Range, FoundCell As Range
    Dim AllCells As Range, mRng As Range
    Dim i%, j%
    Dim s1$, s2$
    Dim aCell As Object
 
    If Val(Application.Version) < 10 Then
        MsgBox "Íåîáõ³äíèé Excel 2002 ³ âèùå"
        Exit Sub
    End If
'    ActiveWindow.DisplayGridlines = Not _
                    ActiveWindow.DisplayGridlines
    Application.FindFormat.Clear
                    
    
    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
 
    Set mRng = Range([a1], [j20])
     With Application.FindFormat
        .Clear
'        .Interior.ColorIndex = xlNone ' íåìàº
        .Font.Bold = False
        .Font.Italic = True
    End With
    Set FirstCell = mRng.Find(What:="", SearchFormat:=True)
        FirstCell.Select
    For Each aCell In mRng.Cells
            If aCell.Font.Bold = False And _
                aCell.Font.Italic = True Then
                Union(Selection, aCell).Select
            End If
    Nex
end sub

Set FoundCell = Cells.Find(What:="", After:=FoundCell, SearchFormat:=True)