Function NumInGroup(XX As Range, UR As Range) As Long
  Application.Volatile False
  Dim UC As Collection, UV As String, II As Long, JJ As Long
  Set UC = New Collection
  On Error Resume Next
  For II = 1 To UR.Count
    UC.Add Left(UR(II), 3), CStr(Left(UR(II), 3))
  Next
  On Error GoTo 0
  UV = Left(XX, 3)
  For JJ = 1 To UC.Count
    If UC(JJ) = UV Then NumInGroup = JJ: Exit Function
  Next
  NumInGroup = 0
End Function

Function NumInGroup2(XX As Range, UR As Range) As Long
  Application.Volatile False
  Dim UD As Object, Data As Variant, II As Long, JJ As String
  Set UD = CreateObject("Scripting.Dictionary")
  Data = UR.value
  For II = LBound(Data) To UBound(Data)
    JJ = Left(Data(II, 1), 3)
    If Not UD.Exists(JJ) Then UD.Add JJ, UD.Count + 1
  Next
  NumInGroup2 = IIf(UD.Exists(Left(XX.value, 3)), IIf(UD(Left(XX.value, 3)) Mod 2, 1, 0), 0)
End Function

Sub CollectFormulas()
  Dim ws As Worksheet, cell As Range, fileNum As Integer, FilePath As String, fileContents As String, output As String, quoteText As String
  FilePath = "C:\Формулы.txt"
  fileNum = FreeFile()
  Open FilePath For Output As fileNum
  For Each ws In ActiveWorkbook.Worksheets
    For Each cell In ws.UsedRange
      If cell.HasFormula Then Print #fileNum, cell.FormulaLocal
    Next cell
  Next ws
  Close fileNum
  Open FilePath For Input As #1
  fileContents = Input$(LOF(1), #1)
  Close #1
  For i = 1 To Len(fileContents)
    If Mid(fileContents, i, 1) = """" Then
      quoteText = ""
      For j = i + 1 To Len(fileContents)
        If Mid(fileContents, j, 1) = """" Then
          i = j: Exit For
        Else
          quoteText = quoteText & Mid(fileContents, j, 1)
        End If
      Next j
      quoteText = Trim(quoteText)
      If InStr(output, quoteText) = 0 Then output = output & quoteText & vbNewLine
    End If
  Next i
  Open FilePath For Output As #1
  Print #1, output
  Close #1
End Sub

Sub CollectControls()
  Dim ws As Worksheet, shp As Shape, cht As ChartObject, cmt As Comment, FilePath As String
  FilePath = "C:\Controls.txt"
  Open FilePath For Output As #1
  For Each ws In ActiveWorkbook.Worksheets
  ' Проходим по всем элементам ActiveSheet.Shapes и собираем тексты
    For Each shp In ws.Shapes
      If shp.Type = msoFormControl Then
        Select Case TypeName(shp.ControlFormat)
          Case "CheckBox", "OptionButton", "GroupBox", "Button", "EditBox", "Label"
            If shp.ControlFormat.Value <> "" Then Print #1, shp.ControlFormat.Value
        End Select
      End If
    Next shp
  ' Проходим по всем элементам ActiveSheet.ChartObjects и собираем тексты
    For Each cht In ws.ChartObjects
      For Each shp In cht.Chart.Shapes
        If shp.Type = msoFormControl Then
          Select Case TypeName(shp.ControlFormat)
            Case "CheckBox", "OptionButton", "GroupBox", "Button", "EditBox", "Label"
              If shp.ControlFormat.Value <> "" Then Print #1, shp.ControlFormat.Value
          End Select
        End If
      Next shp
   Next cht
 ' Проходим по всем комментариям на листе и собираем тексты
   For Each cmt In ws.Comments
     If cmt.Text <> "" Then Print #1, cmt.Text
     Next cmt
   Next ws
 ' Проходим по всем комментариям в Range и собираем тексты
   For Each cmt In ActiveSheet.Comments
     If cmt.Text <> "" Then Print #1, cmt.Text
   Next cmt
   Close #1
End Sub

Sub TranslateValues()
  Dim ws As Worksheet, cell As Range, dict As Object, arr() As Variant, i As Long, j As Long
  Set dict = CreateObject("Scripting.Dictionary")
' Перебираем все листы в книге
  For Each ws In ThisWorkbook.Worksheets
    For Each cell In ws.UsedRange.Cells ' 1273
      Select Case VarType(cell.Value)
        Case vbDouble, vbString
          If Not IsNumeric(cell.Value) And cell.Value <> "" And Not dict.exists(cell.Value) Then
            dict.Add cell.Value, 1
          End If
      End Select
    Next cell
  Next ws
' Создаем отсортированный массив без дубликатов
  ReDim arr(0 To dict.Count - 1)
  i = 0
  For Each Key In dict.keys
    arr(i) = Key
    i = i + 1
  Next Key
' Записываем значения из массива в столбец A на листе "Translate"
  Set ws = ThisWorkbook.Worksheets("Translate")
  For i = 0 To UBound(arr)
    If Not IsNumeric(arr(i)) Then arr(i) = CStr(arr(i))
  Next i
  ws.Range("A1").Resize(UBound(arr) + 1, 1).Value = Application.Transpose(arr)
' Удаляем дубликаты, сортируем
  ws.Range("$A:$A").RemoveDuplicates Columns:=1, Header:=xlNo
  With ws.Sort
    .SortFields.Clear
    .SortFields.Add Key:=ws.Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange ws.Range("A:A")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
End Sub