Option Explicit

Private Sub ListBox1_Click()
    Dim selectedRow As Long
    selectedRow = ListBox1.ListIndex
    If selectedRow = -1 Then Exit Sub

    Dim colStart    As String
    colStart = "CW"

    Dim colEnd      As String
    colEnd = "DB"

    With ActiveSheet

        Dim lr      As Long
        lr = .Cells(.Rows.Count, colStart).End(xlUp).row
        Application.Goto .Range(colStart & (17 + selectedRow) & ":" & colEnd & (17 + selectedRow))
    End With

End Sub

Private Sub UserForm_Initialize()
    Dim col As Long, row As Long
    Dim hasData     As Boolean

    With ActiveSheet

        Dim lr      As Long
        lr = .Cells(.Rows.Count, "CW").End(xlUp).row

        Dim arr     As Variant
        arr = .Range("CW17:DB" & lr).Value

        Dim filteredArr() As Variant
        ReDim filteredArr(1 To UBound(arr, 1), 1 To UBound(arr, 2))

        Dim newCol  As Long
        newCol = 0

        Dim colWidths As String
        colWidths = ""

        For col = 1 To UBound(arr, 2)
            hasData = False

            For row = 1 To UBound(arr, 1)

                If Trim(arr(row, col)) <> "" Then
                    hasData = True
                    Exit For
                End If

            Next row

            If hasData Then
                newCol = newCol + 1

                For row = 1 To UBound(arr, 1)
                    filteredArr(row, newCol) = arr(row, col)
                Next row

                colWidths = colWidths & "50;"
            End If

        Next col

        If newCol > 0 Then
            ReDim Preserve filteredArr(1 To UBound(arr, 1), 1 To newCol)

            With ListBox1
                .ColumnCount = newCol
                .ColumnWidths = Left(colWidths, Len(colWidths) - 1)
                .List = filteredArr
            End With

        End If

    End With

End Sub

Option Explicit

' Вспомогательная функция: проверяет существование листа
Function ЛистСуществует(имяЛиста As String) As Boolean
    On Error Resume Next
    ЛистСуществует = Not ThisWorkbook.Sheets(имяЛиста) Is Nothing
    On Error GoTo 0
End Function

' Процедура: создаёт лист «результат», если его нет
Sub СоздатьЛистРезультат()

    If Not ЛистСуществует("результат") Then

        With ThisWorkbook
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "результат"
            MsgBox "Лист «результат» создан.", vbInformation
        End With

    End If

End Sub

' Основной макрос: поиск по критериям через ListObject
Sub ПоискПоКритериям_Таблицы()

    ' Переменные
    Dim tblБаза As ListObject, tblПоиск As ListObject
    Dim i As Long, isValid As Boolean
    Dim currentDate As Variant
    Dim cellTown As String, cellDamage As String, cellAcceptor As String

    ' Отключение обновления экрана
    Application.ScreenUpdating = False
    On Error GoTo ErrorHandler

    ' Проверка листов
    If Not ЛистСуществует("база") Then
        MsgBox "Ошибка: лист «база» не найден!", vbCritical
        GoTo CleanExit
    End If

    If Not ЛистСуществует("поиск") Then
        MsgBox "Ошибка: лист «поиск» не найден!", vbCritical
        GoTo CleanExit
    End If

    СоздатьЛистРезультат

    Dim wsБаза      As Worksheet
    Set wsБаза = ThisWorkbook.Sheets("база")

    Dim wsПоиск     As Worksheet
    Set wsПоиск = ThisWorkbook.Sheets("поиск")

    Dim wsРезультат As Worksheet
    Set wsРезультат = ThisWorkbook.Sheets("результат")

    ' Получаем таблицы
    On Error Resume Next
    Set tblБаза = wsБаза.ListObjects("Таблица6")
    Set tblПоиск = wsПоиск.ListObjects("Таблица8")
    On Error GoTo ErrorHandler

    If tblБаза Is Nothing Then
        MsgBox "Таблица 'Таблица6' на листе 'база' не найдена!", vbCritical
        GoTo CleanExit
    End If

    If tblПоиск Is Nothing Then
        MsgBox "Таблица 'Таблица8' на листе 'поиск' не найдена!", vbCritical
        GoTo CleanExit
    End If

    ' Чтение критериев из таблицы поиска
    With tblПоиск.DataBodyRange.Rows(1)

        If Not IsDate(.Cells(1, 1).Value) Or Not IsDate(.Cells(1, 2).Value) Then
            MsgBox "Даты в таблице поиска должны быть корректными.", vbCritical
            GoTo CleanExit
        End If

        Dim startDate As Date
        startDate = Int(CDate(.Cells(1, 1).Value))

        Dim endDate As Date
        endDate = Int(CDate(.Cells(1, 2).Value))

        Dim town    As String
        town = LCase(Trim(.Cells(1, 3).Value))

        Dim damageType As String
        damageType = LCase(Trim(.Cells(1, 4).Value))

        Dim acceptor As String
        acceptor = LCase(Trim(.Cells(1, 5).Value))
    End With

    ' Временное сообщение для отладки
    '    MsgBox "Выбрано повреждение: '" & damageType & "'"

    ' Очистка листа результата
    wsРезультат.Cells.Clear

    Dim lastRowRes  As Long
    lastRowRes = 4    ' Строка шапки таблицы

    ' Шапка отчёта
    With wsРезультат
        .Cells(1, 2) = "ОТЧЁТ ПО ПОРЫВАМ ГУП ГО «ОБЛВОДОКАНАЛ»"
        .Cells(1, 2).VerticalAlignment = xlBottom

        .Cells(2, 2) = "за период с " & Format(startDate, "dd.mm.yyyy") & " по " & Format(endDate, "dd.mm.yyyy")
        .Range("B1:B2").Font.Bold = True
        .Range("B1:B2").Font.Size = 14
    End With

    ' Шапка таблицы
    With wsРезультат
        .Cells(lastRowRes, 2) = "Н/П"
        .Cells(lastRowRes, 3) = "Дата"
        .Cells(lastRowRes, 4) = "Номер заявки"
        .Cells(lastRowRes, 5) = "Ф.И.О. заявителя"
        .Cells(lastRowRes, 6) = "Телефон"
        .Cells(lastRowRes, 7) = "Повреждение"
        .Cells(lastRowRes, 8) = "Населённый пункт"
        .Cells(lastRowRes, 9) = "Улица"
        .Cells(lastRowRes, 10) = "Номер дома"
        .Cells(lastRowRes, 11) = "Примечание"
        .Cells(lastRowRes, 12) = "Принявший"
    End With

    lastRowRes = lastRowRes + 1

    ' Цикл по строкам таблицы базы
    For i = 1 To tblБаза.ListRows.Count
        isValid = True

        ' Дата
        currentDate = tblБаза.DataBodyRange.Cells(i, 2).Value

        If IsEmpty(currentDate) Then
            isValid = False
        Else
            currentDate = Trim(CStr(currentDate))
            currentDate = Replace(currentDate, "-", ".")
            currentDate = Replace(currentDate, "/", ".")
            currentDate = Replace(currentDate, " ", ".")

            If IsDate(currentDate) Then
                currentDate = CDate(currentDate)
                If currentDate < startDate Or currentDate > endDate Then isValid = False
            Else
                isValid = False
            End If

        End If

        ' Проверка населённого пункта
        If town <> "" And isValid Then
            cellTown = Trim(Replace(tblБаза.DataBodyRange.Cells(i, 7).Value, Chr(10), ""))
            If InStr(1, LCase(cellTown), town, vbBinaryCompare) = 0 Then isValid = False
        End If

        ' Проверка типа повреждения
        If damageType <> "" And isValid Then
            cellDamage = Trim(Replace(tblБаза.DataBodyRange.Cells(i, 6).Value, Chr(10), ""))
            If InStr(1, LCase(cellDamage), damageType, vbBinaryCompare) = 0 Then isValid = False
        End If

        ' Проверка принявшего
        If acceptor <> "" And isValid Then
            cellAcceptor = Trim(Replace(tblБаза.DataBodyRange.Cells(i, 11).Value, Chr(10), ""))
            If InStr(1, LCase(cellAcceptor), acceptor, vbBinaryCompare) = 0 Then isValid = False
        End If

        ' Запись строки в результат
        If isValid Then

            With wsРезультат
                .Cells(lastRowRes, 2) = tblБаза.DataBodyRange.Cells(i, 1).Value
                .Cells(lastRowRes, 3) = currentDate
                .Cells(lastRowRes, 4) = tblБаза.DataBodyRange.Cells(i, 3).Value
                .Cells(lastRowRes, 5) = tblБаза.DataBodyRange.Cells(i, 4).Value
                .Cells(lastRowRes, 6) = tblБаза.DataBodyRange.Cells(i, 5).Value
                .Cells(lastRowRes, 7) = tblБаза.DataBodyRange.Cells(i, 6).Value
                .Cells(lastRowRes, 8) = tblБаза.DataBodyRange.Cells(i, 7).Value
                .Cells(lastRowRes, 9) = tblБаза.DataBodyRange.Cells(i, 8).Value
                .Cells(lastRowRes, 10) = tblБаза.DataBodyRange.Cells(i, 9).Value
                .Cells(lastRowRes, 11) = tblБаза.DataBodyRange.Cells(i, 10).Value
                .Cells(lastRowRes, 12) = tblБаза.DataBodyRange.Cells(i, 11).Value
            End With

            lastRowRes = lastRowRes + 1
        End If

    Next i

    ' Проверка на наличие данных
    If lastRowRes = 5 Then
        MsgBox "Ничего не найдено. Проверьте критерии поиска.", vbExclamation
        GoTo CleanExit
    End If

    ' Создание таблицы в листе «результат»
    With wsРезультат

        Dim headerRange As Range
        Set headerRange = .Range(.Cells(4, 2), .Cells(lastRowRes - 1, 12))

        On Error Resume Next
        .ListObjects("ТаблицаПорывов").Delete
        On Error GoTo ErrorHandler

        Dim tblRes  As ListObject
        Set tblRes = .ListObjects.Add(xlSrcRange, headerRange, , xlYes)

        tblRes.Name = "ТаблицаПорывов"
        tblRes.TableStyle = "TableStyleMedium2"
        tblRes.ShowAutoFilter = True
    End With

    ' Ширина столбцов как в базе
    Dim c           As Long

    For c = 2 To 12
        wsРезультат.Columns(c).ColumnWidth = wsБаза.Columns(c).ColumnWidth
    Next c

    ' Форматирование шапки таблицы
    With tblRes.HeaderRowRange
        .Font.Bold = True
        .Font.Color = RGB(255, 255, 255)
        .Interior.Color = RGB(0, 51, 102)
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
    End With

    ' Добавление строк "Ответственный / Подпись"
    Dim lastTblRow  As Long
    lastTblRow = tblRes.Range.Rows.Count + tblRes.Range.Row - 1

    With wsРезультат
        .Cells(lastTblRow + 2, 2) = "Ответственный (Ф.И.О.) ______________________"
        .Cells(lastTblRow + 3, 2) = "Подпись ______________________"
        .Cells(lastTblRow + 2, 2).Font.Italic = True
        .Cells(lastTblRow + 2, 2).Font.Size = 11
        .Cells(lastTblRow + 3, 2).Font.Italic = True
        .Cells(lastTblRow + 3, 2).Font.Size = 11
    End With

    ' Сообщение о завершении
    MsgBox "Поиск завершён. Найдено " & (lastRowRes - 5) & " записей." & vbCrLf & _
            "Диапазон таблицы: " & tblRes.Range.Address & vbCrLf & _
            "Шапка закреплена (строка " & tblRes.HeaderRowRange.Row & ").", _
            vbInformation, "Успех"

CleanExit:
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    MsgBox "Ошибка: " & Err.Description & vbCrLf & _
            "Код: " & Err.Number & vbCrLf & _
            "Источник: " & Err.Source, vbCritical, "Критическая ошибка"
    Resume CleanExit
End Sub