Как отсортировать и объединить диапазон столбцов с VBA

Question

У меня есть сгенерированный список номеров деталей (A2: A100) и их количества (B2: B100) для определенного номера заказа (C2: C100).Я пишу сабвуфер, который отфильтрует список номеров деталей для каждого уникального номера детали, а затем создаст новый список с общим количеством каждой детали и каждым заказом, где он будет использоваться.

У меня есть саб, который успешно создает список уникальных номеров деталей (F8: F100), затем другой саб автоматически фильтрует основной список (A2: A100) номеров деталей для каждого уникального номера детали и создаетдиапазон для номеров заказа (C2: C100) для этой конкретной детали.Я попытался объединить диапазон номеров заказов, но моя функция не работает.

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

В настоящее время я получаю сообщение об ошибке несоответствия типов в строке:

For i = 1 To UBound(cellArray, 1)

Если исходный список представлен в colA, B, C с уникальными номерами деталей в 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

Тогда результат должен быть:

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

Используя функцию по ссылке, измените свой код на:

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

Это не зависит от фильтра, который не допускает массовой загрузки массивов.

Вот функция textjoinifs:

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

Вот результат: