Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal lpPath As String) As Long
#Else
Private Declare Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal lpPath As String) As Long
#End If

Option Explicit

Sub test_20New_macro()

    ' Получаем БИК с Лист3!D19
    Dim fff         As String
    fff = Trim(ThisWorkbook.Worksheets("Лист3").Range("D19").Value)

    If fff = "" Then
        MsgBox "БИК пустой!", vbExclamation
        Exit Sub
    End If

    ' Целевой лист
    Dim wsTarget    As Worksheet
    Set wsTarget = ThisWorkbook.Worksheets("Лист5")
    wsTarget.Range("B2:F2").ClearContents
    wsTarget.Columns("E").NumberFormat = "@"

    ' Путь к файлу BIC
    Dim wbPath      As String
    
    ' Временно для теста
    wbPath = ThisWorkbook.Path & "\BIC.xls"
    
    ' Раскомментируйте следуйщую строку, это оригинальный путь к вашему ФАЙЛУ BIC.xls _
    и удалите строку: wbPath = ThisWorkbook.Path & "\BIC.xls" что выше
    '    wbPath = "C:\1\BIC.xls"

    ' Создаём соединение через ADO
    Dim cn          As Object
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & wbPath & ";" & _
            "Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

    ' SQL запрос
    Dim sql         As String
    sql = "SELECT [БИК], [Банк], [Город банка], [К/с] " & _
            "FROM [Лист1$] " & _
            "WHERE [БИК] LIKE '%" & fff & "%'"

    ' Создаём Recordset
    Dim rs          As Object
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sql, cn, 0, 1   ' 0=адекватный тип курсора, 1=read-only

    ' Записываем результат в Лист5
    If Not rs.EOF Then
        wsTarget.Range("B2").Value = rs.Fields("БИК").Value
        wsTarget.Range("C2").Value = rs.Fields("Банк").Value
        wsTarget.Range("D2").Value = rs.Fields("Город банка").Value
        wsTarget.Range("E2").Value = rs.Fields("К/с").Value
        Application.Goto ThisWorkbook.Worksheets("Лист5").Range("B2:E2")
    Else
        MsgBox "Данные по БИК '" & fff & "' не найдены.", vbInformation
    End If

    ' Закрываем
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub

Application.Run Macro:="Nam_Fi!ModDeliter.Delet_sch"

Application.Run "'" & Nam_Fi & "'!ModDeliter.Delet_sch"

On Error Resume Next

On Error GoTo ErrHandler

    Application.Run Macro:="Nam_Fi!ModDeliter.Delet_sch"
    Application.DisplayAlerts = False
    ActiveWorkbook.Close True
    Application.DisplayAlerts = True
    Exit Sub

ErrHandler:
    MsgBox "Ошибка при открытии или выполнении макроса: " & Nam_Fi, vbCritical
End Sub

Option Explicit

Private Sub CommandButton1_Click()
    Dim c           As Range
    Dim i           As Long

    Dim f           As Double
    f = DateSerial(2025, 12, 1)   ' или 45962

    For i = [Dt].Rows.Count To 1 Step -1
        Set c = [Dt].Cells(i)

        If c.Value = f Then
            MsgBox c.Row
            Application.Goto c, True
            Exit For
        End If

    Next i

End Sub

Option Explicit

Private Sub TextBox1_Change()
    Dim txt         As String
    txt = Me.TextBox1.Text
    txt = Replace(txt, ".", ",")
    
    If txt = "" Then
        Cells(ActiveCell.Row, 12).ClearContents
        Exit Sub
    End If

    Dim i As Long, ch As String, cleaned As String, decUsed As Boolean

    For i = 1 To Len(txt)
        ch = Mid$(txt, i, 1)

        Select Case ch
            Case "0" To "9"
                cleaned = cleaned & ch

            Case ","

                If Not decUsed Then
                    cleaned = cleaned & ch
                    decUsed = True
                End If

            Case "-"
                If i = 1 Then cleaned = "-"
        End Select

    Next i

    If cleaned <> txt Then
        Me.TextBox1.Text = cleaned
        Me.TextBox1.SelStart = Len(cleaned)
        Exit Sub
    End If

    If IsNumeric(cleaned) Then
        Cells(ActiveCell.Row, 12).Value = CDec(cleaned)
    End If

End Sub

Private Sub UserForm_Initialize()
    Dim dec         As String
    dec = Application.International(xlDecimalSeparator)

    Dim v           As Variant
    v = Cells(ActiveCell.Row, 12).Value

    If IsNumeric(v) Then
        Me.TextBox1.Text = Replace(CStr(v), ".", dec)
    Else
        Me.TextBox1.Text = ""
    End If

End Sub

Option Explicit

Private Sub UserForm_Initialize()
    Dim dec         As String
    dec = Application.International(xlDecimalSeparator)

    Dim v           As Variant
    v = Cells(ActiveCell.Row, 12).Value

    If IsNumeric(v) Then
        Me.TextBox1.Text = Replace(CStr(v), ".", dec)
    Else
        Me.TextBox1.Text = ""
    End If

End Sub

Option Explicit

Sub CollectDataFromAllSheets()
    Dim ws          As Worksheet
    Dim rngData     As Range
    Dim nextRow     As Long

    ' Ускорение
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim wbCurrent As Workbook, wbReport As Workbook
    Set wbCurrent = ActiveWorkbook
    Set wbReport = Workbooks.Add

    ' Копируем шапку таблицы
    wbCurrent.Worksheets(1).Range("A1:D1").Copy wbReport.Worksheets(1).Range("A1")

    ' Обходим все листы
    For Each ws In wbCurrent.Worksheets

        ' исходный диапазон
        Set rngData = ws.Range("A1:D5")

        ' Пропускаем лист, если там пусто
        If Application.WorksheetFunction.CountA(rngData) = 0 Then
            GoTo NextWs
        End If

        ' Находим первую свободную строку
        nextRow = wbReport.Worksheets(1).Cells(wbReport.Worksheets(1).Rows.Count, 1).End(xlUp).Row + 1

        ' Копируем значения напрямую (без буфера обмена)
        wbReport.Worksheets(1).Range("A" & nextRow).Resize(rngData.Rows.Count, rngData.Columns.Count).Value = rngData.Value

NextWs:
    Next ws

    ' Возврат настроек
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, 1)

Option Explicit

Sub Solutio()
    Dim i           As Long

    Dim ws          As Worksheet
    Set ws = ActiveSheet   ' Можете сами указать конкретный лист, например: Set ws = ThisWorkbook.Worksheets("Лист1")

    Dim lastRow     As Long
    lastRow = ws.Cells(ws.Rows.Count, "AV").End(xlUp).Row

    For i = lastRow To 2 Step -1

        If ws.Cells(i, "AV").Value = "Условие" Then
            ws.Rows(i + 1).Insert Shift:=xlDown
            ws.Cells(i + 1, "A").Value = ws.Cells(i, "A").Value
            ws.Cells(i + 1, "B").Value = ws.Cells(i, "B").Value
            ws.Cells(i + 1, "C").Value = ws.Range("C1").Value & ws.Range("BB1").Value
        End If

    Next i

End Sub

Option Explicit

Sub GetLastSavedBy_Folder()
    Dim wb As Object, oFile As Object

    Const FolderPath As String = "D:\Excel\"   ' Укажите вашу папку

    Dim ws          As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ws.Cells.Clear
    ws.Range("A1:D1").Value = Array("Имя файла", "Путь", "Дата изменения", "LastSavedBy")

    Dim oFSO        As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Dim oFolder     As Object
    Set oFolder = oFSO.GetFolder(FolderPath)

    Dim xlApp       As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.DisplayAlerts = False
    xlApp.Visible = False

    Dim i           As Long
    i = 2

    For Each oFile In oFolder.Files

        If LCase(oFSO.GetExtensionName(oFile.Name)) = "xlsx" _
                Or LCase(oFSO.GetExtensionName(oFile.Name)) = "xlsm" _
                Or LCase(oFSO.GetExtensionName(oFile.Name)) = "xls" Then

            On Error Resume Next
            Set wb = xlApp.Workbooks.Open(oFile.Path, ReadOnly:=True)

            If Not wb Is Nothing Then
                ws.Cells(i, 1).Value = oFile.Name
                ws.Cells(i, 2).Value = oFile.Path
                ws.Cells(i, 3).Value = oFile.DateLastModified
                ws.Cells(i, 4).Value = wb.BuiltinDocumentProperties("Last Author")

                wb.Close False
                Set wb = Nothing
                i = i + 1
            End If

            On Error GoTo 0
        End If

    Next

    xlApp.Quit
    Set xlApp = Nothing
    Set oFSO = Nothing
    Set oFolder = Nothing
    Set oFile = Nothing
End Su

Option Explicit

Sub nextBirthday_All()
    Dim i           As Long
    Dim iLR         As Long
    Dim ДатаРождения As Date
    Dim Лет         As Integer
    Dim ws          As Worksheet
    Dim iLastRow    As Long

    Dim wsDR        As Worksheet
    Set wsDR = ThisWorkbook.Worksheets("ДР")   ' лист для вывода результатов

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual

        ' Очистка диапазона на листе "ДР"
        wsDR.Range(wsDR.Cells(2, 1), wsDR.Cells(wsDR.Rows.Count, 9)).ClearContents

        ' Перебор всех листов, кроме "ДР" и "Титульный"
        For Each ws In ThisWorkbook.Worksheets
            
            If ws.Name <> "ДР" And ws.Name <> "Титульный" Then

                ' Находим последнюю заполненную строку в столбце A на текущем листе
                iLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

                ' Перебор строк
                For i = 2 To iLastRow

                    If ws.Cells(i, "F").Value <> "" And IsDate(ws.Cells(i, "F").Value) Then

                        If DateSerial(Year(Date), Month(ws.Cells(i, "F")), Day(ws.Cells(i, "F"))) - Date >= 0 And _
                                DateSerial(Year(Date), Month(ws.Cells(i, "F")), Day(ws.Cells(i, "F"))) - Date < 45 Then

                            ' Найти следующую пустую строку на листе ДР
                            iLR = wsDR.Cells(wsDR.Rows.Count, "A").End(xlUp).Row + 1

                            ' Копировать значения
                            wsDR.Cells(iLR, "A").Resize(1, 7).Value = ws.Cells(i, "B").Resize(1, 7).Value

                            ' Вычисляем количество лет
                            ДатаРождения = ws.Cells(i, "F").Value
                            Лет = DateDiff("yyyy", ДатаРождения, Date)

                            If Month(Date) < Month(ДатаРождения) Then
                                Лет = Лет - 1
                            ElseIf Month(Date) = Month(ДатаРождения) And Day(Date) < Day(ДатаРождения) Then
                                Лет = Лет - 1
                            End If

                            wsDR.Cells(iLR, "H").Value = Лет
                            wsDR.Cells(iLR, "I").Value = Day(ДатаРождения) & " " & MonthName(Month(ДатаРождения))

                            ' Вспомогательный столбец для сортировки
                            wsDR.Cells(iLR, "J").Value = DateSerial(Year(Date), Month(ДатаРождения), Day(ДатаРождения))

                            If wsDR.Cells(iLR, "J").Value < Date Then
                                wsDR.Cells(iLR, "J").Value = DateSerial(Year(Date) + 1, Month(ДатаРождения), Day(ДатаРождения))
                            End If

                        End If

                    End If
                Next i

            End If

        Next ws

        ' Сортировка на листе "ДР"
        iLR = wsDR.Cells(wsDR.Rows.Count, "A").End(xlUp).Row

        If iLR > 1 Then
            wsDR.Sort.SortFields.Clear

            Dim sortRange As Range
            Set sortRange = wsDR.Range("A2:J" & iLR)

            wsDR.Sort.SortFields.Add Key:=wsDR.Range("J2:J" & iLR), _
                    SortOn:=xlSortOnValues, _
                    Order:=xlAscending, _
                    DataOption:=xlSortNormal
            
            With wsDR.Sort
                .SetRange sortRange
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        
        End If

        ' Очистка вспомогательного столбца
        wsDR.Range("J2:J" & iLR).ClearContents

        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Option Explicit

Private Sub Worksheet_Calculate()
    Dim rngVisible  As Range
    On Error GoTo ErrHandler

    Dim SourceTab As ListObject, TargetTab As ListObject
    Set SourceTab = ThisWorkbook.Worksheets("Лист1").ListObjects("Table1")
    Set TargetTab = ThisWorkbook.Worksheets("Лист2").ListObjects("Table2")

    On Error Resume Next
    Set rngVisible = SourceTab.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not rngVisible Is Nothing Then

        Dim CritDate As Date
        CritDate = Int(rngVisible.Cells(1, 1).Value)

        TargetTab.Range.AutoFilter Field:=1, _
                Criteria1:=">=" & Format(CritDate, "yyyy-mm-dd"), _
                Operator:=xlAnd, _
                Criteria2:="<" & Format(CritDate + 1, "yyyy-mm-dd")
    Else
        If TargetTab.AutoFilter.FilterMode Then TargetTab.AutoFilter.ShowAllData
    End If

    Exit Sub

Cleanup:
    Set rngVisible = Nothing
    Set TargetTab = Nothing
    Set SourceTab = Nothing
    Exit Sub

ErrHandler:
    MsgBox "Произошла ошибка: " & Err.Description
    Resume Cleanup
End Sub