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

ExitHandler:

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrHandler:
    MsgBox "Произошла ошибка: " & Err.Description, vbCritical, "Ошибка"
    On Error Resume Next
    If Not wbk Is Nothing Then wbk.Close SaveChanges:=False

    If Not wOut Is Nothing Then
        Application.DisplayAlerts = False
        wOut.Delete
        Application.DisplayAlerts = True
    End If

    Resume ExitHandler

Option Explicit

Sub SelectUsedRange()
    
    With ActiveWorkbook.Sheets("Лист1")

        'если необходимо выделить диапазон
        Application.Goto .UsedRange

        MsgBox "Диапазон с данными" & .UsedRange.Address, vbInformation
    End With

End Sub

            Cells(Target.Row, 2).Select

            Application.Goto Me.Cells(Target.Row, 2)

    With ActiveSheet   ' Или укажите конкретный нужный вам лист, With Sheet1 или _
                       With ThisWorkbook.Worksheets("Лист1")
        Dim lastRow As Long
        lastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

        Dim lastCol As Long
        lastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

        Dim printRange As String
        printRange = .Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Address
        .PageSetup.PrintArea = printRange
    End With

    With ActiveSheet   ' Или укажите конкретный нужный вам лист, With Sheet1 или _
                       With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row    ' Замените A на нужную вам колонку для определения последней строки в данной колонке

        .PageSetup.PrintArea = "A1:X" & lastRow             ' Замените X на нужную последнюю колонку
    End With

Option Explicit
Option Base 1

Private Sub CommandButton42_Click()
    ComboBox31.Value = Empty
    ThisWorkbook.Worksheets("Данные").Range("G5").Value = Empty
End Sub

Private Sub ComboBox31_Click()

    If IsDate(ComboBox31.Value) Then
        ThisWorkbook.Worksheets("Данные").Range("G5").Value = Format(CDate(ComboBox31.Value), "dd/mm/yyyy")
    Else
        ThisWorkbook.Worksheets("Данные").Range("G5").Value = ""
    End If

End Sub

Private Sub ComboBox31_Change()
    ComboBox31.DropDown
End Sub

Private Sub ComboBox31_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Dim Spisok() As Variant, NewSpisok() As Variant

    If KeyCode <> 38 And KeyCode <> 40 And KeyCode <> 13 Then

        With ThisWorkbook.Worksheets("Нор_Док_МРК")
            Dim i As Long, j As Long

            Dim n   As Long
            n = .Cells(.Rows.Count, 18).End(xlUp).Row

            Dim iRng As Variant
            iRng = .Range(.Cells(3, 18), .Cells(n, 18)).Value

            ReDim Spisok(1 To UBound(iRng, 1), 1 To 1)

            Dim iValidDate As Long
            iValidDate = 0

            For i = 1 To UBound(iRng, 1)

                If IsDate(iRng(i, 1)) Then
                    iValidDate = iValidDate + 1
                    Spisok(iValidDate, 1) = Format(CDate(iRng(i, 1)), "dd/mm/yyyy")
                End If

            Next i

            If iValidDate = 0 Then Exit Sub
            ReDim Preserve Spisok(1 To iValidDate, 1 To 1)
        End With

        Dim b       As Long: b = 0
        Dim txt     As String: txt = ComboBox31.Text
        If txt = "" Then ComboBox31.List = Spisok: Exit Sub

        ComboBox31.Clear
        Erase NewSpisok

        For j = 1 To UBound(Spisok)

            If InStr(1, Spisok(j, 1), txt, vbTextCompare) Then
                b = b + 1
                ReDim Preserve NewSpisok(b)
                NewSpisok(b) = Spisok(j, 1)
            End If

        Next j

        If b <> 0 Then ComboBox31.List = NewSpisok
    End If

End Sub

Private Sub UserForm_Initialize()
    ComboBox31.MatchEntry = fmMatchEntryNone

    With ThisWorkbook.Worksheets("Нор_Док_МРК")
        Dim i       As Long
        Dim cell    As Range

        Dim s       As Long
        s = .Cells(.Rows.Count, 18).End(xlUp).Row

        Dim tempList As Collection
        Set tempList = New Collection

        For Each cell In .Range(.Cells(3, 18), .Cells(s, 18))

            If IsDate(cell.Value) Then
                On Error Resume Next
                tempList.Add Format(CDate(cell.Value), "dd/mm/yyyy")
                On Error GoTo 0
            End If

        Next cell

        If tempList.Count > 0 Then
            
            Dim arr() As Variant
            ReDim arr(0 To tempList.Count - 1, 0 To 0)

            For i = 1 To tempList.Count
                arr(i - 1, 0) = tempList(i)
            Next i

            ComboBox31.List = arr
        End If

        If IsDate(ThisWorkbook.Worksheets("Данные").Range("G5").Value) Then
            Me.ComboBox31.Value = Format(ThisWorkbook.Worksheets("Данные").Range("G5").Value, "dd/mm/yyyy")
        Else
            Me.ComboBox31.Value = ""
        End If

    End With

End Sub

Option Explicit

Sub высота_строк()

    ' Устанавливаем высоту строк на текущем листе
    With ActiveSheet
        .Rows("174:237").RowHeight = 3
        Application.Goto .Range(.Cells(174, 1), .Cells(237, 52)), True
    End With

    ' Устанавливаем высоту строк на листе "22"
    Dim ws          As Worksheet
    On Error Resume Next    ' На случай, если листа "22" не существует
    Set ws = ThisWorkbook.Worksheets("22")
    On Error GoTo 0

    If Not ws Is Nothing Then
        ws.Rows("19:81").RowHeight = 3
        '        Application.Goto ws.Range(ws.Cells(19, 1), ws.Cells(81, 52))
    Else
        MsgBox "Лист с именем '22' не найден!", vbExclamation
    End If

    MsgBox "Готово! Высота строк установлена.", vbInformation
End Sub