How to sort and concatenate a column range with VBA

Question

I have a generated list of part numbers (A2:A100), and their quantities (B2:B100), for a particular order number (C2:C100). I am writing a sub which will filter the list of part numbers for each unique part number and then create a new list with the total quantity of each part and every order where it will be used.

I have a sub that successfully creates a list of unique part numbers (F8:F100), then another sub auto-filters the main list (A2:A100) of part numbers for each unique part number and creates a range for the order numbers (C2:C100) for that particular part. I have tried to concatenate the range of order numbers, but my function is failing.

Sub WOSorter()
    Dim rng As Range
    Dim WOrng As Range
    Dim i As Long
    Dim Limit As Long
    Dim seperator As String

    seperator = ", "

    Limit = Worksheets("Selector").Range("F8:F100").Cells.SpecialCells(xlCellTypeConstants).Count - 1

    For i = 0 To Limit
    Set rng = Worksheets("Selector").Cells(8 + i, 6)
        With Worksheets("Selector").Range("A1")
        .AutoFilter Field:=1, Criteria1:=rng
            Set WOrng = Worksheets("Selector").Range("C2:C100").Cells.SpecialCells(xlCellTypeVisible)
            Worksheets("Selector").Cells(8 + i, 9).Value = ConcatenateRange(WOrng, seperator)
        End With
    Next

    If Worksheets("Selector").AutoFilterMode Then Worksheets("Selector").AutoFilter.ShowAllData

End Sub

-----------------------------------------------------------------------------

Function ConcatenateRange(ByVal WOrng As Range, Optional ByVal seperator As String) As String

Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long

cellArray = WOrng.Value

For i = 1 To UBound(cellArray, 1)
    For j = 1 To UBound(cellArray, 2)
        If Len(cellArray(i, j)) <> 0 Then
            newString = newString & (seperator & cellArray(i, j))
        End If
    Next
Next

If Len(newString) <> 0 Then
    newString = Right$(newString, (Len(newString) - Len(seperator)))
End If

ConcatenateRange = newString

End Function

I am currently getting a type mismatch error on the line:

For i = 1 To UBound(cellArray, 1)

If the original list is in colA, B, C with unique part numbers in colF:

colA      colB     colC               colF
123-4     1        01111              123-4
456-7     2        02222              456-7
123-4     1        03333              789-0 
789-0     1        04444
456-7     3        05555

Then the result should be:

colA      colB     colC               colF         colI
123-4     1        01111              123-4        01111, 03333
456-7     2        02222              456-7        02222, 05555 
123-4     1        03333              789-0        04444
789-0     1        04444
456-7     3        05555

Answer 1

Using the function on the link change your code to:

Sub WOSorter()

    Dim seperator As String
    seperator = ", "

    With Worksheets("Selector")
        Dim lstrow As Long
        lstrow = .Cells(.Rows.Count, "F").End(xlUp).Row


        Dim i As Long
        For i = 2 To lstrow
            .Range("I" & i).Value = TEXTJOINIFS(.Range("C:C"), seperator, .Range("A:A"), .Range("F" & i).Value)
        Next i

     End With


End Sub

This does not rely on filter which will not allow the bulk load of arrays.

Here is the textjoinifs function:

Function TEXTJOINIFS(rng As Range, delim As String, ParamArray arr() As Variant) As String
    Dim rngarr As Variant
    rngarr = Intersect(rng, rng.Parent.UsedRange).Value

    Dim condArr() As Boolean
    ReDim condArr(1 To Intersect(rng, rng.Parent.UsedRange).Rows.Count) As Boolean

    TEXTJOINIFS = ""

    Dim i As Long
    For i = LBound(arr) To UBound(arr) Step 2
        Dim colArr() As Variant
        colArr = Intersect(arr(i), arr(i).Parent.UsedRange).Value
        Dim j As Long
        For j = LBound(colArr, 1) To UBound(colArr, 1)

            If Not condArr(j) Then
                Dim charind As Long
                charind = Application.Max(InStr(arr(i + 1), ">"), InStr(arr(i + 1), "<"), InStr(arr(i + 1), "="))
                Dim opprnd As String
                If charind = 0 Then
                    opprnd = "="
                Else
                    opprnd = Left(arr(i + 1), charind)
                End If
                Dim t As String
                t = """" & colArr(j, 1) & """" & opprnd & """" & Mid(arr(i + 1), charind + 1) & """"
                If Not Application.Evaluate(t) Then condArr(j) = True
            End If
        Next j
    Next i

    For i = LBound(rngarr, 1) To UBound(rngarr, 1)
        If Not condArr(i) Then
            TEXTJOINIFS = TEXTJOINIFS & rngarr(i, 1) & delim
        End If
    Next i
    If TEXTJOINIFS <> "" Then
        TEXTJOINIFS = Left(TEXTJOINIFS, Len(TEXTJOINIFS) - Len(delim))
    End If

End Function

Here is the ouput: