Sub Translit()
 
    Dim Rus As Variant
    Rus = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", _
    "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", _
    "щ", "ъ", "ы", "ь", "э", "ю", "я", "А", "Б", "В", "Г", "Д", "Е", _
    "Ё", "Ж", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", _
    "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", "Я")
 
    Dim Eng As Variant
    Eng = Array("a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "j", _
    "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", _
    "sh", "sch", "''", "y", "'", "e", "yu", "ya", "A", "B", "V", "G", "D", _
    "E", "JO", "ZH", "Z", "I", "J", "K", "L", "M", "N", "O", "P", "R", _
    "S", "T", "U", "F", "KH", "TS", "CH", "SH", "SCH", "''", "Y", "'", "E", "YU", "YA")

    For Each Txt In Range(Selection.Address)
    For I = 1 To Len(Txt)
        с = Mid(Txt, I, 1)
        flag = 0
        For J = 0 To 65
            If Rus(J) = с Then
                outchr = Eng(J)
                flag = 1
                Exit For
            End If
        Next J
        If flag Then outstr = outstr & outchr Else outstr = outstr & с
    Next I
     
    Txt.Value = outstr
    outstr = ""
    Next Txt
End Sub

=СУММЕСЛИМН(AX:AX;A:A;">="&СЕГОДНЯ()-ДЕНЬ(СЕГОДНЯ()-1);A:A;"<="&СЕГОДНЯ())

Range("BV142").Formula = "=SUMIFS(C[-24],C[-73],"">=""&TODAY()-DAY(TODAY()-1),C[-73],""<=""&TODAY())"

ZaMecPlan = CCur(Range("BV142"))

Range("BV142").Clear

ZaMecPlan = SUMIFS(C[-24],C[-73],"">=""&TODAY()-DAY(TODAY()-1),C[-73],""<=""&TODAY())

For i = 1 To UBound(arFiles)   
.StatusBar = "Обработка файла " & i & " из " & UBound(arFiles) 

UserForm1.Label1.Caption = "Обработка файла " & i & " из " & UBound(arFiles)
UserForm1.Repaint

Sub Объединение_множества_книг_в_один_лист()   
  
Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов   
Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат   
Const blInsertNames = True 'вставлять строку заголовка (книга, лист) перед содержимым листа   
  
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _   
i As Integer, stbar As Boolean, clTarget As Range   
  
On Error Resume Next 'если указанный путь не существует, обзор начнется с пути по умолчанию   
ChDir strStartDir   
On Error GoTo 0   
With Application 'меньше писанины   
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)   
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла   
Set wbTarget = Workbooks.Add(template:=xlWorksheet)   
Set shTarget = wbTarget.Sheets(1)   
.ScreenUpdating = False   
stbar = .DisplayStatusBar   
.DisplayStatusBar = True   
  
For i = 1 To UBound(arFiles)   
.StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)   
Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)   
For Each shSrc In wbSrc.Worksheets   
If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой   
Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)   
If blInsertNames Then   
clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name   
Set clTarget = clTarget.Offset(1, 0)   
End If   
shSrc.UsedRange.Copy clTarget   
End If   
Next   
wbSrc.Close False 'закрыть без запроса на сохранение   
Next   
.ScreenUpdating = True   
.DisplayStatusBar = stbar   
.StatusBar = False   
  
On Error Resume Next 'если указанный путь не существует и его не удается создать,   
'обзор начнется с последней использованной папки   
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir   
ChDir strSaveDir   
On Error GoTo 0   
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")   
  
If VarType(arFiles) = vbBoolean Then 'если не выбрано имя   
GoTo save_err   
Else   
On Error GoTo save_err   
wbTarget.SaveAs arFiles   
End If   
End   
save_err:   
MsgBox "Книга не сохранена!", vbCritical   
End With   
End Sub 

Function HasDifColor(rg As Range) As Boolean
  HasDifColor = IsNull(rg.Cells(1).Characters.Font.Color)
End Function

Public Function hasSeveralTextColors(txtCell As Range) As Boolean
    severalColors = False
    With txtCell.Cells(1)
        firstColor = .Characters(1, 1).Font.ColorIndex
        For i = 2 To .Characters.Count
            If .Characters(i, 1).Font.ColorIndex <> firstColor Then
                severalColors = True
                Exit For
            End If
        Next i
    End With
    hasSeveralTextColors = severalColors
End Function