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

Private Sub CommandButton4_Click()

    With ThisWorkbook.Worksheets("Лист1")

        ' Проверка: если в A7 уже есть та же дата, что и в TextBox1
        If IsDate(.Range("A7").Value) And IsDate(Me.TextBox1.Value) Then
            
            If CDate(.Range("A7").Value) = CDate(Me.TextBox1.Value) Then
                MsgBox "Эта дата уже есть в ячейке A7. Ввод запрещён!", vbExclamation
                Exit Sub
            End If
        
        End If

        ' Если проверки пройдены - запись значений
        .Range("B7").Value = Me.TextBox1.Value
        .Range("B8").Value = Me.TextBox2.Value
    End With

End Sub

        If Cell = InStr(AnforderungVal, vbNewLine) = 1 Then 'Тут видимо что то не правильно

If InStr(Target.Value, vbNewLine) = 1 Then

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim LineBreaks  As Long

    If Not Intersect(Target, Range("A1:A10000")) Is Nothing Then

        Dim Cell
        Cell = Target.Value

        If Cell = InStr(Cell, vbNewLine) = 1 Then
            Rows.RowHeight = Rows.RowHeight + 5
        End If

        If Not IsEmpty(Cell) Then
            LineBreaks = Len(Cell) - Len(Replace(Cell, Chr(10), ""))
            MsgBox "Количество переносов в ячейке: " & LineBreaks, vbInformation
        End If

    End If

End Sub

Option Explicit

Private Sub cb_регион_Change()

    If cb_регион.Text = "Добавить новый" Then
        '        Unload Me

        Dim region  As String
        region = InputBox("Укажите название нового региона", "Регион")

        If Len(region) = 0 Then Exit Sub

        With ThisWorkbook.Worksheets("Списки_постоянные")

            Dim CледПустаяСтрока As Long
            CледПустаяСтрока = .Cells(.Rows.Count, 1).End(xlUp).Row + 1

            .Cells(CледПустаяСтрока, 1) = region
        End With

        '        MsgBox region
        Call UserForm_Initialize
        Me.cb_регион.Value = region
    End If

End Sub

Private Sub UserForm_Initialize()
    Dim iArr        As Variant

    With ThisWorkbook.Worksheets("Списки_постоянные")
        iArr = .Range("A2", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value
    End With

    Me.cb_регион.List = iArr
End Sub

Option Explicit

Private Sub UserForm_Initialize()

    With Sheets("Нор_Док_МРК")

        ' 1) Способ
        CheckBox2.Value = IIf(.Range("EC6").Value = "Да", True, False)

        '        ' 2) Способ
        '        ' Раскомментируйте следущую строку если будете использовать этот способ
        '        CheckBox2.Value = (.Range("EC6").Value = "Да")

        '        ' 3) Способ, он анологичен 1-му способу но там более соркащённый способ написан
        '        If .Range("EC6").Value = "Да" Then
        '            CheckBox2.Value = True
        '        ElseIf .Range("EC6").Value = "Нет" Then
        '            CheckBox2.Value = False
        '        End If

    End With

End Sub

Option Explicit

Private Sub cb_регион_Change()

    If cb_регион.Text = "Добавить новый" Then
        Unload Me

        Dim region  As String
        region = InputBox("Укажите название нового региона", "Регион")

        With ThisWorkbook.Worksheets("Списки_постоянные")

            Dim CледПустаяСтрока As Long
            CледПустаяСтрока = .Cells(.Rows.Count, 1).End(xlUp).Row + 1

            Cells(CледПустаяСтрока, 1) = region
        End With

        MsgBox region
    End If

End Sub

Private Sub UserForm_Initialize()
    Dim iArr        As Variant

    With ThisWorkbook.Worksheets("Списки_постоянные")
        iArr = .Range("A2", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value
    End With

    With Me.cb_регион
        .List = iArr
    End With

End Sub

Option Explicit

Sub Sbor_imen_failov_i_stranic()
    Dim i           As Long
    Dim xRg         As Range
    Dim xStr        As String
    Dim xFdItem     As Variant
    Dim xFileNum    As Long
    Dim RegExp      As Object

    Dim fPath       As String
    fPath = ThisWorkbook.Path & Application.PathSeparator

    Dim xFileName   As String
    xFileName = Dir(fPath & "*.pdf", vbDirectory)
    
    If xFileName = "" Then
        MsgBox "В папке нет PDF-файлов: " & fPath, vbExclamation
        Exit Sub
    End If

    On Error Resume Next
    Worksheets("Приложения").Delete
    On Error GoTo 0
    Worksheets.Add.Name = "Приложения"

    Set xRg = Sheets("Приложения").Range("A1")
    Range("A:B").ClearContents
    Range("A1:B1").Font.Bold = True
    xRg = "Имя файла"
    xRg.Offset(0, 1) = "Кол-во страниц"
    i = 2
    xStr = ""

    Do While xFileName <> ""
        Cells(i, 1) = xFileName
        Set RegExp = CreateObject("VBscript.RegExp")
        RegExp.Global = True
        RegExp.Pattern = "/Type\s*/Page[^s]"
        xFileNum = FreeFile
        Open (xFdItem & xFileName) For Binary As #xFileNum
        xStr = Space(LOF(xFileNum))
        Get #xFileNum, , xStr
        Close #xFileNum
        Cells(i, 2) = RegExp.Execute(xStr).Count
        i = i + 1
        xFileName = Dir
    Loop

    Columns("A:B").AutoFit
End Sub

Option Explicit

Sub Макрос44()
    Dim currentMonth As Integer
    currentMonth = Month(Date)

    Dim currentYear As Integer
    currentYear = Year(Date)

    With Sheet1
        Dim col     As Long

        Dim lastCol As Long
        lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column

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

        Dim formulaStr As String
        formulaStr = "=VLOOKUP(B4,Лист4!A:D,4,FALSE)"

        For col = 3 To lastCol

            If IsDate(.Cells(2, col).Value) Then

                If Year(.Cells(2, col).Value) = currentYear And Month(.Cells(2, col).Value) = currentMonth Then
                    .Cells(4, col).Formula = formulaStr
                    .Range(.Cells(4, col), .Cells(lastRow, col)).FillDown

                    With .Range(.Cells(4, col), .Cells(lastRow, col))
                        .Value = .Value
                    End With

                End If

            End If

        Next

    End With

End Sub

Option Explicit

Sub Макрос4()
    Dim currentMonth As Integer
    currentMonth = Month(Date)

    With Sheet1
        Dim col     As Long

        Dim lastCol As Long
        lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column

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

        Dim formulaStr As String
        formulaStr = "=VLOOKUP(B4,Лист4!A:D,4,FALSE)"

        For col = 3 To lastCol

            If IsDate(.Cells(2, col).Value) Then

                If Month(.Cells(2, col).Value) = currentMonth Then
                    .Cells(4, col).Formula = formulaStr
                    .Range(.Cells(4, col), .Cells(lastRow, col)).FillDown

                    With .Range(.Cells(4, col), .Cells(lastRow, col))
                        .Value = .Value
                    End With

                End If

            End If

        Next col

    End With

End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, j As Long
    On Error GoTo CleanFail

    If Target.Cells.Count > 1 Then Exit Sub
    Dim eventsDisabled As Boolean
    eventsDisabled = False

    If Not Intersect(Target, Range("B3:B100")) Is Nothing Then
        Application.EnableEvents = False
        eventsDisabled = True

        Dim Search  As Variant
        Search = Target.Value

        With Лист3

            Dim iLast As Long
            iLast = .Cells(.Rows.Count, "AD").End(xlUp).Row

            Dim dataArr As Variant
            dataArr = .Range("AD2:BA" & iLast).Value

            Dim foundIndex As Long
            foundIndex = 0

            For i = 1 To UBound(dataArr, 1)

                If dataArr(i, 1) = Search Then
                    foundIndex = i
                    Exit For
                End If

            Next i

            If foundIndex > 0 Then

                Me.Cells(Target.Row, 3).Value = dataArr(foundIndex, 2)
                Me.Cells(Target.Row, 4).Value = dataArr(foundIndex, 9)
                Me.Cells(Target.Row, 5).Value = dataArr(foundIndex, 10)

                Dim fullText As String
                fullText = Me.Cells(Target.Row, 5).Value

                If Trim(fullText) <> "" Then

                    Dim spacePos As Long
                    spacePos = InStr(fullText, " ")

                    Dim resultValue As String

                    If spacePos > 0 Then
                        resultValue = Mid(fullText, 1, spacePos - 1)
                    Else
                        resultValue = "1"
                    End If

                Else
                    resultValue = ""
                End If

                Me.Cells(Target.Row, 6).Value = resultValue

                Me.Cells(Target.Row, 7).Value = dataArr(foundIndex, 13)
                Me.Cells(Target.Row, 8).Value = dataArr(foundIndex, 16)
                Me.Cells(Target.Row, 9).Value = dataArr(foundIndex, 19)
            Else

                For j = 2 To 9
                    Me.Cells(Target.Row, j).ClearContents
                Next j

                MsgBox "В базе нет такого номера! ", vbExclamation
            End If

        End With

        Dim lastRow As Long
        lastRow = ThisWorkbook.ActiveSheet.Cells(ThisWorkbook.ActiveSheet.Rows.Count, "B").End(xlUp).Row

        With ThisWorkbook.ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add key:=ThisWorkbook.ActiveSheet.Range("I3:I" & lastRow), _
                    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

            '        .SortFields.Add key:=ThisWorkbook.ActiveSheet.Range("I3:I" & lastRow), _
                     '                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

            .SetRange ThisWorkbook.ActiveSheet.Range("B3:I" & lastRow)
            .Apply
        End With

    End If

CleanExit:
    If eventsDisabled Then Application.EnableEvents = True
    Exit Sub

CleanFail:
    MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    Resume CleanExit
End Sub

Option Explicit

Sub CombineWorkbooks_v3()
    Dim importWB As Workbook, importWS As Worksheet
    Dim tbl As ListObject, visibleRow As Range
    Dim FilesToOpenItem As Variant
    Dim j As Long

    On Error GoTo ErrorHandler

    Dim colsToExtract As Variant
    colsToExtract = Array(1, 3, 4, 5)    ' A, C, D, E
    
    Dim numOutCols As Long
    numOutCols = UBound(colsToExtract) - LBound(colsToExtract) + 1

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False

        Dim FilesToOpen As Variant
        FilesToOpen = .GetOpenFilename( _
                FileFilter:="Excel files (*.xls*), *.xls*", _
                MultiSelect:=True, Title:="Выберите файлы для объединения")

        If TypeName(FilesToOpen) = "Boolean" Then
            MsgBox "Не выбрано ни одного файла!"
            GoTo CleanExit
        End If
    
    End With

    Dim итогWB As Workbook, итогWS As Worksheet
    Set итогWB = Workbooks.Add(xlWBATWorksheet)
    Set итогWS = итогWB.Sheets(1)
    итогWS.Name = "ИТОГ"

    Dim pasteRow    As Long
    pasteRow = 1

    Dim savePath    As String
    savePath = Left(FilesToOpen(1), InStrRev(FilesToOpen(1), "\"))

    Dim headersWritten As Boolean
    headersWritten = False

    For Each FilesToOpenItem In FilesToOpen
        Set importWB = Workbooks.Open(FilesToOpenItem, ReadOnly:=True)

        ' Извлекаем дату из имени файла
        Dim fileName As String, extractedDate As String
        fileName = Mid(FilesToOpenItem, InStrRev(FilesToOpenItem, "\") + 1)
        extractedDate = ExtractDateFromFileName(fileName)

        For Each importWS In importWB.Worksheets

            For Each tbl In importWS.ListObjects
                If tbl.DataBodyRange Is Nothing Then GoTo NextTable

                If Not headersWritten Then
                    
                    For j = LBound(colsToExtract) To UBound(colsToExtract)
                        итогWS.Cells(pasteRow, j - LBound(colsToExtract) + 1).Value = _
                                tbl.HeaderRowRange.Cells(1, colsToExtract(j)).Value
                    Next j

                    итогWS.Cells(pasteRow, numOutCols + 1).Value = "КОДЫ ИТОГ"
                    итогWS.Cells(pasteRow, numOutCols + 2).Value = "ДАТА"
                    pasteRow = pasteRow + 1
                    headersWritten = True
                End If

                Dim rowCount As Long
                rowCount = 0

                For Each visibleRow In tbl.DataBodyRange.Rows
                    If Not visibleRow.EntireRow.Hidden Then rowCount = rowCount + 1
                Next visibleRow

                If rowCount = 0 Then GoTo NextTable

                Dim outArr() As Variant
                ReDim outArr(1 To rowCount, 1 To numOutCols + 2)

                Dim i As Long
                i = 0

                For Each visibleRow In tbl.DataBodyRange.Rows
                    
                    If Not visibleRow.EntireRow.Hidden Then
                        i = i + 1

                        For j = LBound(colsToExtract) To UBound(colsToExtract)
                            outArr(i, j - LBound(colsToExtract) + 1) = _
                                    visibleRow.Cells(1, colsToExtract(j)).Value
                        Next j

                        Dim codeValue As Variant
                        codeValue = visibleRow.Cells(1, 4).Value

                        If Not IsEmpty(codeValue) Then
                            outArr(i, numOutCols + 1) = "[Код товара] = " & codeValue & "ИЛИ"
                        Else
                            outArr(i, numOutCols + 1) = ""
                        End If

                        ' Добавляем дату из имени файла
                        outArr(i, numOutCols + 2) = extractedDate
                    End If
                
                Next visibleRow

                итогWS.Cells(pasteRow, 1).Resize(UBound(outArr, 1), UBound(outArr, 2)).Value = outArr
                pasteRow = pasteRow + UBound(outArr, 1)

NextTable:
            Next tbl
        
        Next importWS

        importWB.Close SaveChanges:=False
    Next FilesToOpenItem

    итогWS.Columns.AutoFit

    ' Сортировка по столбцу A по убыванию
    With итогWS.Sort
        .SortFields.Clear
        .SortFields.Add Key:=итогWS.Range("A2:A" & итогWS.Cells(итогWS.Rows.Count, "A").End(xlUp).row), _
                SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange итогWS.UsedRange
        .Header = xlYes
        .Apply
    End With

    итогWB.SaveAs fileName:=savePath & "Итог.xlsx", FileFormat:=xlOpenXMLWorkbook
    итогWB.Close SaveChanges:=False

    MsgBox "Объединение завершено. Данные сохранены в 'Итог.xlsx'"

CleanExit:
    
    With Application
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:
    MsgBox "Произошла ошибка: " & Err.Description, vbCritical, "Ошибка"
    If Not importWB Is Nothing Then On Error Resume Next: importWB.Close SaveChanges:=False
    If Not итогWB Is Nothing Then On Error Resume Next: итогWB.Close SaveChanges:=False
    Resume CleanExit
End Sub

Private Function ExtractDateFromFileName(fileName As String) As String
    Dim re          As Object
    Set re = CreateObject("VBScript.RegExp")
    
    With re
        .Pattern = "\b\d{2}\.\d{2}\.\d{4}\b"
        .Global = False
        .IgnoreCase = True
    End With

    If re.test(fileName) Then
        ExtractDateFromFileName = re.Execute(fileName)(0)
    Else
        ExtractDateFromFileName = ""
    End If

End Function