Bdtjtk

I am using autofilter to look up a criteria in column A in Sheet1 and return the corresponding value from column B in a table, however I want to be able to make it concatenate if column B contents are in two cells. Column A is blank under the identifier in cases like this.

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

Untested, I basically just inserted some code within your If branch.

Few things to note:

• 
  Application.Transpose (used below to convert 2-d array to 1-d array) can only handle arrays of length ~65.5k. So if you have more filtered items than that, not all of them may get concatenated.


• Cells have a character limit of ~32.8k I think. If the result of your concatenation violates this limit, you may get an error when trying to assign the result.

But other than that, should work fine. Also, both of your Application.ScreenUpdating assignments seem to be True. You might want to look into that.

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