Sub Rename_File()
    Dim sFilePath As String, LastRow As Long, Cell As Range
    sFilePath = Split(Range("A1").Text, " ", 3)(2)    'путь к текущей паке
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
    
    If Application.WorksheetFunction.CountA(Range("A3:A" & LastRow)) <> Application.WorksheetFunction.CountA(Range("B3:B" & LastRow)) Then Exit Sub
    
    For Each Cell In Range("A3:A" & LastRow)
        If Dir(sFilePath & Cell.Text, 16) <> "" And ThisWorkbook.FullName <> sFilePath & Cell.Text Then
            Name sFilePath & Cell.Text As GetNewName(sFilePath, Cell.Offset(0, 1).Text) 'переименовываем файл
        End If
    Next Cell
    'Update file list
    Call ListFilesInFolder(sFilePath)
    Shell "explorer.exe " & sFilePath, vbNormalFocus
End Sub

Private Function GetNewName(sFilePath As String, sName As String) As String
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim sBase As String
    sBase = fso.GetBaseName(sName)
    Dim sExte As String
    sExte = "." & fso.GetExtensionName(sName)
    Dim sFull As String
    Dim sIndx As String
    Dim ii As Long
    
    Do
        If ii = 0 Then
            sIndx = ""
        Else
            sIndx = "(" & ii & ")"
        End If
        sFull = sFilePath & sBase & sIndx & sExte
        If Dir(sFull, 16) = "" Then Exit Do
                
        ii = ii + 1
    Loop
    GetNewName = sFull
End Function

Sub LongStringSort()
    Dim rTarg As Range
    Set rTarg = Selection
    Set rTarg = rTarg.Columns(1)
    Set rTarg = Intersect(rTarg, rTarg.Parent.UsedRange)
    Set rTarg = rTarg.Areas(1)
    If rTarg.Cells.CountLarge = 1 Then Exit Sub
    
    Dim arr As Variant
    arr = rTarg.Value
    ClearArray arr
    arr = GetSortArray(arr)
    If IsEmpty(arr) Then Exit Sub
    rTarg.Value = arr
End Sub

Private Function GetSortArray(arr As Variant) As Variant
    Dim mrr As Variant
    mrr = GetMultiColumnArray(arr)
    If IsEmpty(mrr) Then Exit Function
    
    With Workbooks.Add(1)
        With .Sheets(1)
            Dim rr As Range
            Set rr = .Cells(1, 1).Resize(UBound(mrr, 1), UBound(mrr, 2))
            rr.Value = mrr
            With .Sort
                .SortFields.Clear
                Dim xr As Long
                For xr = 1 To rr.Columns.Count
                    .SortFields.Add Key:=rr.Columns(xr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                Next
                .SetRange rr
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            mrr = rr.Value
        End With
        .Close False
    End With
    
    Dim orr As Variant
    orr = GetOneColumnArray(mrr)
    
    GetSortArray = orr
End Function

Private Function GetOneColumnArray(arr As Variant) As Variant
     Dim orr As Variant
     ReDim orr(1 To UBound(arr, 1), 1 To 1)
     
     Dim ya As Long
     Dim xa As Long
     Dim ss As String
     For ya = 1 To UBound(arr, 1)
        ss = ""
        For xa = 1 To UBound(arr, 2)
            ss = ss & arr(ya, xa)
        Next
        orr(ya, 1) = ss
     Next
     
     GetOneColumnArray = orr
End Function

Private Function GetMultiColumnArray(arr As Variant) As Variant
    Const nStep = 255

    Dim nx As Long
    nx = GetColumnNumbers(arr, nStep)
    If nx = 0 Then Exit Function
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To nx)
    
    Dim ss As String
    Dim xb As Long
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
         If arr(ya, 1) <> "" Then
            xb = 1
            Do
                ss = Mid(arr(ya, 1), 1 + (xb - 1) * nStep, nStep)
                If ss = "" Then Exit Do
                brr(ya, xb) = ss
                xb = xb + 1
            Loop
         End If
    Next
    
    GetMultiColumnArray = brr
End Function

Private Function GetColumnNumbers(arr As Variant, nn As Long) As Long
    Dim ni As Long
    Dim nMax As Long
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If arr(ya, 1) <> "" Then
            ni = Len(arr(ya, 1)) \ nn + 1
            If nMax < ni Then nMax = ni
        End If
    Next
    GetColumnNumbers = nMax
End Function

Private Sub ClearArray(arr As Variant)
    Dim ya As Long
    Dim xa As Long
    For ya = LBound(arr, 1) To UBound(arr, 1)
        For xa = LBound(arr, 2) To UBound(arr, 2)
            If IsError(arr(ya, xa)) Then
                arr(ya, xa) = Empty
            End If
        Next
    Next
End Sub

=ЕСЛИ((100000-МАКС(('партии кол-во и срок'!$C$2:$C$29=A2)*(100000-'партии кол-во и срок'!$J$2:$J$29)))>($F$1+30);"да";"нет")

=ЕСЛИ((1000-МАКС(('партии кол-во и срок'!$C$2:$C$29=A2)*(1000-'партии кол-во и срок'!$G$2:$G$29)))>40;"да";"нет")

=ЕСЛИ((ДЛСТР(A2)=8)*(СЧЁТЕСЛИМН('партии кол-во и срок'!C:C;A2)=4);"да";"нет")

Private Const myColumn = "E"

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Column <> Range(myColumn & 1).Column Then Exit Sub
            
    On Error Resume Next
    Dim dValue As Double
    dValue = Target.Value
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Undo
    Target.Value = Target.Value + dValue
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    On Error GoTo 0
End Sub

=(ЛЕВСИМВ(A2;4)="I60.")+(ЛЕВСИМВ(A2;4)="I61.")+(ЛЕВСИМВ(A2;4)="I62.")+(ЛЕВСИМВ(A2;4)="I63.")+(ЛЕВСИМВ(A2;4)="I64.")

=ИНДЕКС('для форума_1.xlsx'!Таблица1[[#Все];[Адрес объекта]];ПОИСКПОЗ($O$55;'[для форума_1.xlsx]АИС РСМ'!$L:$L;0))

Sub test()
    Dim c1 As Range
    Dim c2 As Range
    Dim found As Boolean
    For Each c1 In Range("F4:F8")
        found = False
        For Each c2 In Range("C4:C21")
            'Если данные в столбце 2 найдены то
            If c2.Value = c1.Value Then
                'Если найденная ячейка в столбце 2 была уже закрашена желтым, то в столбце   3   написать " ОК – желтая"
                If c1.Cells(1, 2).Interior.Color = RGB(255, 255, 0) Then
                    c1.Cells(1, 2).Value = "ОК – желтая"
                Else
                    'В столбец 3, рядом с текущей ячейкой,  записать "ОК".
                    c1.Cells(1, 2).Value = "ОК"
                End If
                'закрасить найденную ячейку в столбце 2 с совпадающим значением из столбца 1 желтым цветом.
                c1.Cells(1, 2).Interior.Color = c2.Interior.Color
                'В столбец 4 записать адрес ячейки из столбца 2.
                c1.Cells(1, 3).Value = c2.Address(0, 0)
                found = True
                Exit For
            End If
        Next
        'Если ячейка с совпадающим значением в столбце 2 не была найдена
        If Not found Then
            'то в столбце   3   написать  не найдена и закрашивает ячейку  красным цветом
            c1.Cells(1, 2).Value = "не найдена"
            c1.Cells(1, 2).Interior.Color = RGB(255, 0, 0)
        End If
    Next
End Sub

Const myRange = "E5:M24"

Sub poisk()
Dim YourRange As Range, iFoundRng As Range, k As Long
Dim firstAddress As String, findDan As String, arrZam

Set YourRange = Range(myRange)
'Set YourRange = Application.InputBox _
'        (Prompt:="Выделите диапазон ячеек", _
'        Title:="", Type:=8)
'If YourRange Is Nothing Then MsgBox "Выберите диапазон, а то ни чего делать не буду", vbInformation, "НУ?!"

findDan = "д"
arrZam = Split("1~2~3~4~5", "~")
k = UBound(arrZam) + 1
If Not YourRange Is Nothing Then
            Set iFoundRng = YourRange.Find(What:=findDan, LookIn:=xlFormulas, LookAt:=xlWhole) 'поиск
            If Not iFoundRng Is Nothing Then 'если нашли
                firstAddress = iFoundRng.Address 'запоминаем адрес найденной ячейки, чтобы продолжить поиск по листу
                iFoundRng.Offset(, 1).Resize(, k).Value = arrZam
                
                
                'Debug.Print firstAddress
                Do 'цикл поиска, т.к. одно и то же значение может встречаться много раз
                    Set iFoundRng = YourRange.FindNext(iFoundRng) 'продолжаем поиск на том же листе
iFoundRng.Offset(, 1).Resize(, k).Value = arrZam
                    'Debug.Print iFoundRng.Address
                Loop While iFoundRng.Address <> firstAddress
            End If


End If
End Sub

=СУММЕСЛИМН(исх!$C:$C;исх!$A:$A;ДАТА(ГОД(СЕГОДНЯ());МЕСЯЦ(СЕГОДНЯ())-1;СТРОКА(1:1));исх!$B:$B;ВРЕМЯ(СТОЛБЕЦ();0;0))

=ЕСЛИ(ПОДСТАВИТЬ(ЯЧЕЙКА("адрес";B6);"$";"")=$D$2;$E$2;"")

=ЕСЛИОШИБКА(ВПР(A1;A2:C$1048576;3;0);0)--(СЧЁТЕСЛИМН(A1:A$1048576;A1;B1:B$1048576;B1)=1)

Private Sub Workbook_Open()
    LockSheet Sheets("Реестр")
End Sub

Option Explicit

Private Const MAX_PASSWORD_LENGTH = 3
Private Const letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"

Sub LockActiveSheetSheet()
    LockSheet ActiveSheet
End Sub

Public Sub LockSheet(sh As Worksheet)
    Dim rPassword As Range
    Set rPassword = Sheets("АПП").Range("U82")

    Dim sPassword As String
    sPassword = rPassword.Value
    On Error Resume Next
    sh.Unprotect Password:=sPassword
    On Error GoTo 0
    
    sPassword = GetPassword(MAX_PASSWORD_LENGTH * Rnd() + 1)
    
    'sPassword = InputBox("Заблокировать лист паролем?", "", sPassword)
    If sPassword <> "" Then
        'Debug.Print Now, sPassword
        On Error Resume Next
        sh.Protect Password:=sPassword
        If Err = 0 Then rPassword.Value = sPassword
        On Error GoTo 0
    End If
End Sub

Private Function GetPassword(lLen As Byte) As String
    
    Dim arr As Variant
    ReDim arr(1 To lLen)
    
    Dim crr As Variant
    crr = GetCharArray()
    
    Randomize
    Dim ya As Long
    Dim yc As Long
    For ya = 1 To UBound(arr)
        yc = (UBound(crr) - 1) * Rnd() + 1
        arr(ya) = crr(yc)
    Next
        
    GetPassword = Join(arr, "")
End Function

Private Function GetCharArray() As Variant
    Dim arr As Variant
    ReDim arr(1 To Len(letters))
    
    Dim ya As Long
    For ya = 1 To UBound(arr)
        arr(ya) = Mid(letters, ya, 1)
    Next
    GetCharArray = arr
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Column <> 1 Then Exit Sub
            
    On Error Resume Next
    Dim dValue As Double
    dValue = Target.Value
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Undo
    Target.Value = Target.Value + dValue
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    On Error GoTo 0
End Sub

Option Explicit

Private Const MAX_PASSWORD_LENGTH = 3

Sub LockActiveSheetSheet()
    LockSheet ActiveSheet
End Sub

Private Sub LockSheet(sh As Worksheet)
    Dim sPassword As String
    sPassword = GetPassword(MAX_PASSWORD_LENGTH * Rnd() + 1)
    
    sPassword = InputBox("Заблокировать лист паролем?", "", sPassword)
    If sPassword <> "" Then
        Debug.Print Now, sPassword
        On Error Resume Next
        sh.Protect Password:=sPassword
        On Error GoTo 0
    End If
End Sub

Private Function GetPassword(lLen As Byte) As String
    Const letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
    
    Dim brr As Variant
    ReDim brr(1 To Len(letters))
    
    Dim yb As Long
    For yb = 1 To UBound(brr)
        brr(yb) = Mid(letters, yb, 1)
    Next
    
    Dim arr As Variant
    ReDim arr(1 To lLen)
    
    Randomize
    Dim ya As Long
    For ya = 1 To UBound(arr)
        yb = UBound(brr) * Rnd() + 1
        arr(ya) = brr(yb)
    Next
        
    GetPassword = Join(arr, "")
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
            
    On Error Resume Next
    Dim dValue As Double
    dValue = Target.Value
    Application.EnableEvents = False
    Application.Undo
    Target.Value = Target.Value + dValue
    Application.EnableEvents = True
    On Error GoTo 0
End Sub

=ЛЕВПР(A5;ТЕКСТ($C$3;"ДД.ММ")&"!J:P")

Function ЛЕВПР(искомое_значение As Variant, диапазон As Variant) As Variant
    Dim arr As Variant
    arr = Split(диапазон, "!")
    Dim rr As Range
    On Error Resume Next
    Set rr = Sheets(arr(0)).Range(arr(1))
    On Error GoTo 0
    If Not rr Is Nothing Then
        Dim yy As Long
        On Error Resume Next
        yy = WorksheetFunction.Match(искомое_значение, rr.Columns(rr.Columns.Count), 0)
        On Error GoTo 0
        If yy > 0 Then
            ЛЕВПР = rr.Cells(yy, 1).Value
        End If
    End If
End Function

Sub Экспорт_Из_Всех_Фигур()
    On Error Resume Next
    Dim sh As Shape
    Dim текстФигуры As String
    For Each sh In ActiveSheet.Shapes
        текстФигуры = sh.DrawingObject.Caption
        If текстФигуры Like "Заявка" & "*" Then
            Application.Goto Range("I" & sh.TopLeftCell.Row)
            Range("I" & sh.TopLeftCell.Row).Value = CDbl(Replace(Right(текстФигуры, 3), "_", "", , , vbTextCompare))
        End If
        текстФигуры = ""
    Next
    
    On Error GoTo 0
End Sub

Sub Экспорт_Из_Выбран_Текст_Фигуры()
    Dim Sh
    Dim текстФигуры As String
    On Error GoTo Ext_Sub
    ' Проверяем заголовок активной фигуры на наличие "Заявка" в начале текста
    If Selection.Caption Like "Заявка" & "*" Then
        Set Sh = Selection
'        ' Проверяем, является ли фигура текстовой
'        If Sh.Type = msoTextBox Then
'            текстФигуры = Sh.TextFrame.Characters.Text
'        End If
        текстФигуры = Selection.Caption
        ' Адрес ячейки, в которую поместится текст
        ' В ячейки записываются последние три символа в качестве целого числа
        Range("I" & Sh.TopLeftCell.Row).Value = CDbl(Replace(Right(текстФигуры, 3), "_", "", , , vbTextCompare))
    End If
Ext_Sub:
End Sub

=ИНДЕКС(ДВССЫЛ(ТЕКСТ($C$3;"ДД.ММ")&"!$J$1:$J$14");ПОИСКПОЗ($A:$A;ДВССЫЛ(ТЕКСТ($C$3;"ДД.ММ")&"!$P:$P");0))

Sub DateMerge()
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange).Areas(1).Rows(1)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    If rr.Row < 3 Then Exit Sub
    If rr.Columns.Count = 1 Then Exit Sub
    
    rr.Offset(-2).UnMerge
    rr.Offset(-1).UnMerge
    
    Dim arr As Variant
    arr = rr.Value
    
    Dim mrr As Variant
    Dim drr As Variant
    ReDim mrr(1 To 1, 1 To UBound(arr, 2))
    ReDim drr(1 To 1, 1 To UBound(arr, 2))
    
    Dim rm As Range
    Dim xb As Long
    Dim xe As Long
    Dim db As Long
    
    xb = 1
    db = 1
    For xe = 2 To UBound(arr, 2)
        If xe = UBound(arr, 2) Then
            Set rm = Range(rr.Cells(1, xb), rr.Cells(1, xe)).Offset(-2)
            rm.Merge
            mrr(1, xb) = arr(1, xb)
            xb = xe
            
            Set rm = Range(rr.Cells(1, db), rr.Cells(1, xe)).Offset(-1)
            rm.Merge
            drr(1, db) = "'" & Format(Day(arr(1, db)), "00") & " - " & Format(Day(arr(1, xe)), "00")
            db = xe
        ElseIf Month(arr(1, xe)) <> Month(arr(1, xe - 1)) Then
            Set rm = Range(rr.Cells(1, xb), rr.Cells(1, xe - 1)).Offset(-2)
            rm.Merge
            mrr(1, xb) = arr(1, xb)
            xb = xe
            
            Set rm = Range(rr.Cells(1, db), rr.Cells(1, xe - 1)).Offset(-1)
            rm.Merge
            drr(1, db) = "'" & Format(Day(arr(1, db)), "00") & " - " & Format(Day(arr(1, xe - 1)), "00")
            db = xe
        Else
            Select Case Day(arr(1, xe))
            Case 10, 20
                Set rm = Range(rr.Cells(1, db), rr.Cells(1, xe)).Offset(-1)
                rm.Merge
                drr(1, db) = "'" & Format(Day(arr(1, db)), "00") & " - " & Format(Day(arr(1, xe)), "00")
                
                db = xe + 1
            End Select
        End If
    Next
    
    rr.Offset(-2).Value = mrr
    rr.Offset(-1).Value = drr
End Sub