If Not Intersect(Target, Range("F" & lLastRow)) Is Nothing Then Exit Sub

Sub Color_RUS_LAT()   ' Выделяет русские символы в Selection ЗЕЛЁНЫМ, латинские - КРАСНЫМ
   If TypeName(Selection) <> "Range" Then Exit Sub
   With ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible)
      If Intersect(Selection, .Cells) Is Nothing Then Exit Sub
      Intersect(Selection, .Cells).Select
   End With
   Dim rCell As Range, i&
   With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With
   For Each rCell In Selection
      For i = 1 To Len(rCell)
         If Mid$(rCell, i, 1) Like "[А-Яа-яЁё]" Then rCell.Characters(i, 1).Font.Color = vbGreen
         If Mid$(rCell, i, 1) Like "[A-Za-z]" Then rCell.Characters(i, 1).Font.Color = vbRed
      Next i
   Next rCell
   With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With
End Sub

Private Sub Repair_RUS()   ' заменить латинские буквы такими же по начертанию русскими
   With ActiveSheet.UsedRange
      If Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)) Is Nothing Then Exit Sub
      Application.ScreenUpdating = False: Application.EnableEvents = False
      Dim LATChr$: LATChr = "CcEeTOopPAaHKkXxBM"
      Dim RUSChr$: RUSChr = "СсЕеТОорРАаНКкХхВМ"
      Dim i%
      For i = 1 To Len(LATChr)
         Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)).Replace _
               What:=Mid(LATChr, i, 1), Replacement:=Mid(RUSChr, i, 1), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
      Next i
   End With
   Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Private Sub Repair_LAT()   ' заменить русские буквы такими же по начертанию латинскими
   With ActiveSheet.UsedRange
      If Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)) Is Nothing Then Exit Sub
      Application.ScreenUpdating = False: Application.EnableEvents = False
      Dim arrENG: arrENG = Split("C c E e T O o p P A a H K k X x B M")
      Dim arrRUS: arrRUS = Split("С с Е е Т О о р Р А а Н К к Х х В М")
      Dim i%
      For i = 0 To UBound(arrENG)
         Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)).Replace _
               What:=arrRUS(i), Replacement:=arrENG(i), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
      Next i
   End With
   Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Sub Draws_0D_Select()   ' выделить НА ЛИСТЕ все рисунки с нулевыми размерами
   Dim oDraw As Shape
   If ActiveSheet.DrawingObjects.Count = 0 Then:   MsgBox "В выделенном диапазоне нет рисунков", , "Нет объектов!": Exit Sub
   For Each oDraw In ActiveSheet.DrawingObjects.ShapeRange
      If oDraw.Width = 0 Or oDraw.Height = 0 Then oDraw.Select (False)
   Next
End Sub

On Error Resume Next

ActiveWindow.RangeSelection.SpecialCells(xlCellTypeConstants).Select

   With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With
   …
   With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With

rArea.FormulaLocal = rArea.FormulaLocal

Sub Repair_Value()   ' в выделенных ячейках исправить экспортированные как текст данные чтобы нормально опознались числа
   Dim rArea As Range
   On Error Resume Next
   ActiveWindow.RangeSelection.SpecialCells(xlCellTypeConstants).Select
   If Err Then Exit Sub
   With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With
   For Each rArea In Selection.Areas
      rArea.FormulaLocal = rArea.FormulaLocal
   Next rArea
   With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With
End Sub

Function ИЗВЛЕЧЬ_ЦЕЛЫЕ(ParamArray ДИАПАЗОН())
'---------------------------------------------------------------------------------------
' Author       : Alex_ST, v__step, nerv
' URL          : http://www.excelworld.ru/forum/3-1012-97065-16-1401961860
' Topic        : Функция (UDF) "ИЗВЛЕЧЬЦЕЛЫЕ"
' Purpose      : Создать массив из целых чисел, извлечённых из текста произвольно расположенных ячеек
' Notes        : К полученному массиву-результату можно применять любые стандартные формулы листа
'---------------------------------------------------------------------------------------
   Dim rArea, rCell, sStr$, oMatches, i&, Arr()
   On Error GoTo xlErrEXIT
   For Each rArea In ДИАПАЗОН
      For Each rCell In IIf(rArea.Count = 1, Array(rArea.Value), rArea.Value)
         sStr = sStr & " " & rCell
      Next rCell
   Next rArea
   With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\d+": Set oMatches = .Execute(sStr): End With
   If oMatches.Count = 0 Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrNA): Exit Function      ' вернуть ошибку #Н/Д если чисел нет
   '   If oMatches Is Nothing Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrNA): Exit Function   ' вернуть ошибку #Н/Д если чисел нет
   ReDim Arr(1 To oMatches.Count)
   For i = 0 To oMatches.Count - 1: Arr(i + 1) = CLng(oMatches(i).Value): Next i
   ИЗВЛЕЧЬ_ЦЕЛЫЕ = Arr
xlErrEXIT:    If Err Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrValue)   ' вернуть ошибку #ЗНАЧ! если была ошибка
End Function

Private Function FileIsBusy(File$) As Boolean   ' не открывая файла проверяет, открыт ли он вообще кем-либо
   Dim FN%: FN = FreeFile
   On Error Resume Next
   Open File For Random Access Write Lock Write As #FN
   Close #FN
   FileIsBusy = (Err <> 0)
End Function

Private Sub test_FileIsBusy()
Debug.Print FileIsBusy("C:\Temp\Hotkeys.xls")
End Sub
'-------------------------------------------------
Private Sub test_Статус_Книги()
'Свойство UserStatus возвращает 2D-массив (1, 1 to 3), содержащий информацию:
'UserStatus(1,1) - имя пользователя, открывшего книгу в режиме общего доступа,
'UserStatus(1,2) - дата и время, когда этот пользователь открыл книгу,
'UserStatus(1,3) - режим открытия книги (1 - монопольный доступ, 2 - общий доступ).
Debug.Print IIf(ThisWorkbook.UserStatus(1, 3) = 1, "Exclusive", "Shared")
End Sub

Sub NoDups_in_Range()
'---------------------------------------------------------------------------------------
' Procedure    : NoDups_in_Range
' Author       : Alex_ST
' Topic_HEADER : Макрос "NoDups_in_Range" (Подсчёт и вывод уникальных значений в диапазоне)
' Topic_URL    : http://www.excelworld.ru/forum/3-39-25849-16-1347208019
' Purpose      : вывод списка уникальных значений из ВИДИМЫХ ячеек задаваемого диапазона с возможностью подсчёта числа повторов
'---------------------------------------------------------------------------------------
   Dim Addr, rRng As Range, rCell As Range
   On Error Resume Next
   '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
   ' замена Application.InputBox("...", "...", Type:=8), не работающего на других листах и листах с УФ формулой
   Addr = Application.InputBox("Где брать список?", "Выбор диапазона данных", "=" & Selection.Address, Type:=0)
   If TypeName(Addr) = "Boolean" Then Exit Sub    ' если нажали "Отмена", то Addr = False
   Addr = Range(Trim(Mid(Application.ConvertFormula(Addr, xlR1C1, xlA1, True), 2))).AddressLocal(0, 0, 1, 1)
   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   Set rRng = Intersect(Range(Addr).Parent.UsedRange, Range(Addr).Parent.Cells.SpecialCells(xlCellTypeVisible), Range(Addr)): If Err Then Exit Sub
   With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare   ' создаем временный словарь
      For Each rCell In rRng
         If Trim(rCell) <> "" Then .Item(Trim(rCell)) = .Item(Trim(rCell)) + 1   ' попытка записи значения по отсутствующему ключу добавит ключ в словарь
      Next
      If MsgBox("Видимые ячейки указанного диапазона содержат " & vbCrLf & .Count & " уникальных значений." & vbCrLf & _
                "Вывести список на лист?", vbYesNo Or vbInformation, "Параметры списка") = vbNo Then Exit Sub
      '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      ' замена Application.InputBox("...", "...", Type:=8), не работающего на других листах и листах с УФ формулой
      Addr = Application.InputBox("Куда выводить список?", "Выбор диапазона данных", "=" & Selection(1).Address, Type:=0)
      If TypeName(Addr) = "Boolean" Then Exit Sub   ' если нажали "Отмена", то Addr = False
      Addr = Range(Trim(Mid(Application.ConvertFormula(Addr, xlR1C1, xlA1, True), 2))).AddressLocal(0, 0, 1, 1)
      '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
      Range(Range(Addr)(1, 1), Range(Addr)(.Count, 1)).Value = Application.WorksheetFunction.Transpose(.Keys)
      Range(Addr).Parent.Activate  ' перейти к листу, куда выводятся данные
      If MsgBox("Вывести количества в соседний столбец?", vbQuestion + vbYesNo, "Вывод данных") = vbYes Then
         Range(Range(Addr)(1, 2), Range(Addr)(.Count, 2)).NumberFormat = "General"
         Range(Range(Addr)(1, 2), Range(Addr)(.Count, 2)).Value = Application.WorksheetFunction.Transpose(.Items)
         Range(Range(Addr)(1, 1), Range(Addr)(.Count, 2)).Activate  ' выделить диапазон выведенных данных
      Else
         Range(Range(Addr)(1, 1), Range(Addr)(.Count, 1)).Activate  ' выделить диапазон выведенных данных
      End If
   End With
End Sub