Question

我正在使用自动过滤器在Sheet1的A列中查找条件，并从表中的B列返回相应的值，但是如果B列的内容位于两个单元格中，我希望能够将其连接起来。在这种情况下，标识符下的A列为空白。

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

Image

Answer 1

未经测试，我基本上只是在您的If分支中插入了一些代码。

几件事要注意：

Application.Transpose（以下用于将2维数组转换为1维数组）只能处理长度约为65.5k的数组。因此，如果您过滤的项目多于此，那么并非所有的项目都可以串联起来。

但是除此之外，应该可以正常工作。另外，您的两个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

如果自动过滤器标识符下的单元格为空，如何串联B列的内容？

1 个答案: