Цикл и запись столбцов в отфильтрованной таблице, если одна ячейка соответствует условию

Question

• 1000 и несколько «х», распределенных случайным образом. Я хочу записать заголовки столбцов тогда и только тогда, когда в столбце есть хотя бы один «x», и пропустить другой столбец. Мой макрос работает, когда фильтр не применен. Я думаю, что у меня также возникают проблемы с пустыми ячейками, когда я устанавливаю диапазон столбцов.

Есть ли у вас какие-нибудь предложения?

Sub Filtre()

Dim CategoryName() As String
Dim NumberCategory As Integer
NumberCategory = 0

Dim CategoryCell As Range
Dim TopCell As Range
Dim CategoryRange As Range
Dim ObjectNumber As Integer
Dim intValueToFind As String
Dim TableObject As ListObject
Dim Rng As Range
Dim TableCell As Range

    Set TableObject = ActiveSheet.ListObjects("Table_objet")
    Set TopCell = TableObject.HeaderRowRange.Find("AC1")
    Set CategoryRange = Range(TopCell, TopCell.End(xlToRight))
    ObjectNumber = TableObject.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1

    intValueToFind = "x"

For Each CategoryCell In CategoryRange

            CategoryCell.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
            Set Rng = Range(ActiveCell, ActiveCell.End(xlDown)).Cells.SpecialCells(xlCellTypeVisible)

            For Each TableCell In Rng
                If TableCell.Value = intValueToFind Then
                    NumberCategory = NumberCategory + 1
                    ReDim Preserve CategoryName(NumberCategory - 1)
                    CategoryName(NumberCategory - 1) = CategoryCell.Value
                    Exit For
                End If

            Next TableCell
        Next CategoryCell

Dim msg As String

Dim i As Integer
    msg = "Category in array: " & vbCrLf
    For i = 1 To NumberCategory
        msg = msg & vbCrLf & CategoryName(i - 1)
    Next i
MsgBox msg