Поиск и выгрузка данных из массива

[staniiislav]

Приветы Уважаемые форумчане, в очередной раз прошу вашей помощи, в небольшом изменении функции EducatedFool (Игорь).
Суть вопроса состаи в следующем:
1) чтобы поиск производится с конца массива (не с первого значения и до последнего, а с последнего и до первого);
2) если значение столбца А не равно ячейки [I1], сразу переходить к следующему значению в столбце А. Вообщем я пытался переделать код, так чтобы показать уникальные значения столбца Б и С.
И еще один вопрос, как в коде добавить чтобы вытягивало значения не только с Б и С столбцов, а еще допустим с нескольких столбцов?
И как я понял вытягивается первое найденное значения в массиве?
Спасибо за внимание и ответы.

[staniiislav]

Помогите пожалуйста довести код до конца.
Осталось только производить поиск с конца.

Function JoinedArray(ByVal arr As Variant, ByVal ComparedColumn As Long, _
                     Optional ByVal ColumnsForSum As String, Optional ByVal ColumnsForJoin As String, _
                     Optional ByVal JoinSeparator As String = ", ") As Variant
    ' осуществляет объединение строк в массиве
    ' получает в качестве параметров исходный массив, и номер столбца ComparedColumn,
    ' по которому осуществляется сравнение строк
    ' ---------------------------------------------
    ' для совпадающих строк:
    ' - суммируются значения в столбцах, перечисленных через запятую в переменной ColumnsForSum
    ' - соединяются (через разделитель JoinSeparator) значения в столбцах,
    '   перечисленных через запятую в переменной ColumnsForJoin
    ' ---------------------------------------------
    ' функция возвращает новый массив (возможно, с меньшей размерностью по вертикали)


    On Error Resume Next
    If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical: Exit Function
    If ComparedColumn > UBound(arr, 2) Then MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function
    If ComparedColumn < LBound(arr, 2) Then MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function

    For i = LBound(arr, 1) To UBound(arr, 1) 'если я делаю так  For i = UBound(arr, 1) To LBound(arr, 1) Step-1, то начинает считать с конца, но где еще нужно поменять?
        If Cells(1, 9) = Cells(i, 3) Then
        If arr(i, ComparedColumn) <> "" Then
            For j = i + 1 To UBound(arr, 1)
                If arr(j, ComparedColumn) = arr(i, ComparedColumn) Then
                    ' для последующего удаления этой строки из массива
                    arr(j, ComparedColumn) = Empty    ' затираем значение в сравниваемом столбце

                    ' суммируем строки - результат в верхнюю строку
                    For Each col In Split(ColumnsForSum, ",")
                        nCol = Val(col)
                        If nCol > 0 And nCol <= UBound(arr, 2) And nCol <> ComparedColumn Then
                            arr(i, nCol) = Val(Replace(arr(i, nCol), ",", ".")) _
                                           + Val(Replace(arr(j, nCol), ",", "."))
                        End If
                    Next

                    ' сцепляем строки - результат в верхнюю строку
                    For Each col In Split(ColumnsForJoin, ",")
                        nCol = Val(col)
                        If nCol > 0 And nCol <= UBound(arr, 2) And nCol <> ComparedColumn Then
                            If Len(Trim(arr(j, nCol))) > 0 Then
                                arr(i, nCol) = Trim(arr(i, nCol)) & JoinSeparator & Trim(arr(j, nCol))
                            End If
                        End If
                    Next
                End If
            Next j
        End If
        End If
    Next i

    ' удаляем ненужные (пустые) строки
    Dim iCount As Long    ' кол-во непустых строк
    For i = LBound(arr) To UBound(arr)
        If Cells(1, 9) = Cells(i, 3) Then
        iCount = iCount - (arr(i, ComparedColumn) <> "")
        End If
    Next i

    ' формируем новый массив
    ReDim narr(LBound(arr, 1) To iCount + LBound(arr, 1) - 1, LBound(arr, 2) To UBound(arr, 2))

    iCount = LBound(narr)    ' счётчик записей
    For i = LBound(arr, 1) To UBound(arr, 1)
    If Cells(1, 9) = Cells(i, 3) Then
        If arr(i, ComparedColumn) <> "" Then
            For j = LBound(arr, 2) To UBound(arr, 2)
                narr(iCount, j) = arr(i, j)
            Next j
            iCount = iCount + 1
        End If
    End If
    Next i

    JoinedArray = narr
End Function

Вот новый файлик:

[staniiislav]

вроде получилось, вы не могли бы посмотреть все ли я правильно сделал?
Спасибо

Sub ПримерИспользования()
    ' отключаем обновление экрана
    Application.ScreenUpdating = False
    ' считываем массив с листа - в него попадут все заполненные строки
    Массив = Range([A1], Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value

    ' объединяем уникальные
    arr = JoinedArray(Массив, 1)

    Range("e:h").ClearContents    ' очистка содержимого столбцов E F G
    ' заносим массив на лист, начиная с ячейки e1
    Range("e1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

    Range("e:h").EntireColumn.AutoFit
End Sub

Sub Очистка()
    Range("e:h").ClearContents
End Sub

Function JoinedArray(ByVal arr As Variant, ByVal ComparedColumn As Long, _
                     Optional ByVal ColumnsForSum As String, Optional ByVal ColumnsForJoin As String, _
                     Optional ByVal JoinSeparator As String = ", ") As Variant
    ' осуществляет объединение строк в массиве
    ' получает в качестве параметров исходный массив, и номер столбца ComparedColumn,
    ' по которому осуществляется сравнение строк
    ' ---------------------------------------------
    ' для совпадающих строк:
    ' - суммируются значения в столбцах, перечисленных через запятую в переменной ColumnsForSum
    ' - соединяются (через разделитель JoinSeparator) значения в столбцах,
    '   перечисленных через запятую в переменной ColumnsForJoin
    ' ---------------------------------------------
    ' функция возвращает новый массив (возможно, с меньшей размерностью по вертикали)


    On Error Resume Next
    If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical: Exit Function
    If ComparedColumn > UBound(arr, 2) Then MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function
    If ComparedColumn < LBound(arr, 2) Then MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function

    For i = UBound(arr, 1) To LBound(arr, 1) Step -1
        If Cells(1, 9) = Cells(i, 3) Then
        If arr(i, ComparedColumn) <> "" Then
            For j = i - 1 To LBound(arr, 1) Step -1
                If arr(j, ComparedColumn) = arr(i, ComparedColumn) Then
                    ' для последующего удаления этой строки из массива
                    arr(j, ComparedColumn) = Empty    ' затираем значение в сравниваемом столбце

                    ' суммируем строки - результат в верхнюю строку
                    For Each col In Split(ColumnsForSum, ",")
                        nCol = Val(col)
                        If nCol > 0 And nCol <= UBound(arr, 2) And nCol <> ComparedColumn Then
                            arr(i, nCol) = Val(Replace(arr(i, nCol), ",", ".")) _
                                           + Val(Replace(arr(j, nCol), ",", "."))
                        End If
                    Next

                    ' сцепляем строки - результат в верхнюю строку
                    For Each col In Split(ColumnsForJoin, ",")
                        nCol = Val(col)
                        If nCol > 0 And nCol <= UBound(arr, 2) And nCol <> ComparedColumn Then
                            If Len(Trim(arr(j, nCol))) > 0 Then
                                arr(i, nCol) = Trim(arr(i, nCol)) & JoinSeparator & Trim(arr(j, nCol))
                            End If
                        End If
                    Next
                End If
            Next j
        End If
        End If
    Next i

    ' удаляем ненужные (пустые) строки
    Dim iCount As Long    ' кол-во непустых строк
    For i = UBound(arr) To LBound(arr) Step -1
        'If Cells(1, 9) = Cells(i, 3) Then
        iCount = iCount - (arr(i, ComparedColumn) <> "")
        'End If
    Next i

    ' формируем новый массив
    ReDim narr(LBound(arr, 1) To iCount + LBound(arr, 1) - 1, LBound(arr, 2) To UBound(arr, 2))

    iCount = LBound(narr)    ' счётчик записей
    For i = UBound(arr, 1) To LBound(arr, 1) Step -1
    If Cells(1, 9) = Cells(i, 3) Then
        If arr(i, ComparedColumn) <> "" Then
            For j = UBound(arr, 2) To LBound(arr, 2) Step -1
                narr(iCount, j) = arr(i, j)
            Next j
            iCount = iCount + 1
        End If
    End If
    Next i

    JoinedArray = narr
End Function

[staniiislav]

тему можно закрывать