Sub latin()
     Dim iLastRow As Long, jLastRow As Long, i As Long
     iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
     With Sheets("Лист2")
         jLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 2
         .Cells(jLastRow, 4).Font.Bold = True
         .Cells(jLastRow, 4).Value = "Латиница в фио"
         For i = 2 To iLastRow
             Set cll = .Cells(jLastRow + 1, 1)
             If isLat(Cells(i, 2).Value) And Cells(i, 3) <> "0000000000" Then
                 Union(Range(Cells(i, 1), Cells(i, 10)), Range(Cells(i, 10), Cells(i, 18))).Copy cll
                 jLastRow = jLastRow + 1
             End If
             For j = 1 To Len(cll.Offset(, 1).Value)
                 l = Mid(cll.Offset(, 1).Value, j, 1)
                 If l Like "[A-Z]" Or l Like "[a-z]" Then
                     cll.Offset(, 1).Characters(Start:=j, Length:=1).Font.Color = -16776961
                 End If
             Next j
         Next
         .Select
     End With
End Sub

Function isLat(t As String) As Boolean
     isLat = False
     For i = 1 To Len(t)
         l = Mid(t, i, 1)
         If l Like "[А-Я]" Or l Like "[а-я]" Then
             isLat = True
             Exit Function
         End If
     Next i
End Function

        For i = 2 To iLastRow
             Application.StatusBar = "Номер строки = " & i