Как объединить содержимое столбца B, если ячейка с идентификатором автофильтра не заполнена?

Question

Я использую автофильтр для поиска критериев в столбце A в Sheet1 и возврата соответствующего значения из столбца B таблицы, однако я хочу иметь возможность объединить его, если содержимое столбца B находится в двух ячейках. Столбец А под идентификатором пуст в таких случаях.

Sub ReturnTIResults()

Dim r As Range

Application.ScreenUpdating = True

With Worksheets("Sheet1") ' reference results sheet
    If IsEmpty(.Range("A1")) Then .Range("A1").Value = "dummy header" 
    ' if A1 is empty, put a "dummy" header to make AutoFilter work properly

    .AutoFilterMode = False
    With .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)).Offset(, -1) 'reference referenced sheet column A range from row 1 down to column B last not empty cell
        .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C" ' fill referenced range blank cells with the same value as the not empty cell above
        .AutoFilter Field:=1, Criteria1:="=TI"
        On Error Resume Next
        Set r = .Resize(.Rows.Count - 1, 1).Offset(1,1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not r Is Nothing Then r.Copy Worksheets("Search Results").Range("B7")
        .Parent.AutoFilterMode = False

        .SpecialCells(xlCellTypeFormulas).ClearContents ' clear cell with formulas
        If .Range("A1").Value = "dummy header" Then 
.Range("A1").ClearContents ' remove any "dummy" header
    End With
End With

Application.ScreenUpdating = True

End Sub

Изображение

Answer 1

Не проверено, я просто вставил некоторый код в вашу ветку If.

Несколько замечаний:

• Application.Transpose (используется ниже для преобразования 2-го массива в 1-й массив) может обрабатывать только массивы длиной ~ 65,5 КБ. Поэтому, если у вас больше отфильтрованных элементов, не все из них могут быть объединены.
• Ячейки имеют ограничение на число персонажей ~ 32.8k, я думаю. Если результат вашей конкатенации нарушает этот предел, вы можете получить ошибку при попытке присвоить результат.

Но кроме этого, должно работать нормально. Кроме того, оба ваших Application.ScreenUpdating задания кажутся True. Возможно, вы захотите разобраться в этом.

Option Explicit

Sub ReturnTIResults()

    Dim r As Range

    Application.ScreenUpdating = True

    With Worksheets("Sheet1") ' reference results sheet
            If IsEmpty(.Range("A1")) Then .Range("A1").Value = "dummy header"
            ' if A1 is empty, put a "dummy" header to make AutoFilter work properly

            .AutoFilterMode = False
            With .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)).Offset(, -1) 'reference referenced sheet column A range from row 1 down to column B last not empty cell
                .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C" ' fill referenced range blank cells with the same value as the not empty cell above
                .AutoFilter Field:=1, Criteria1:="=TI"
                On Error Resume Next
                Set r = .Resize(.Rows.Count - 1, 1).Offset(1, 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not r Is Nothing Then
                    If r.Rows.Count > 1 Then
                        Dim toConcatenate As Variant
                        toConcatenate = Application.Transpose(r.Value2)
                        toConcatenate = VBA.Strings.Join(toConcatenate, ", ") ' <-- Change to whatever delimiter you want
                        Worksheets("Search Results").Range("B7").Value2 = toConcatenate
                    Else
                        Worksheets("Search Results").Range("B7").Value2 = r.Value2
                    End If
                End If
                .Parent.AutoFilterMode = False

                .SpecialCells(xlCellTypeFormulas).ClearContents ' clear cell with formulas
                If .Range("A1").Value = "dummy header" Then .Range("A1").ClearContents ' remove any "dummy" header
            End With
    End With

    Application.ScreenUpdating = True

End Sub