Эта функция позволяет осуществить объединение строк в двумерном массиве.

функция получает в качестве параметров исходный массив, и номер столбца ComparedColumn,
по которому осуществляется сравнение строк
---------------------------------------------
для совпадающих строк:
- суммируются значения в столбцах, перечисленных через запятую в переменной ColumnsForSum
- соединяются (через разделитель JoinSeparator) значения в столбцах,
перечисленных через запятую в переменной ColumnsForJoin
---------------------------------------------
функция возвращает новый массив (возможно, с меньшей размерностью по вертикали)

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)

        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

    Next i

    ' удаляем ненужные (пустые) строки

    Dim iCount As Long    ' кол-во непустых строк

    For i = LBound(arr) To UBound(arr)

        iCount = iCount - (arr(i, ComparedColumn) <> "")

    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 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

    Next i

    JoinedArray = narr

End Function

Пример использования:

Sub ПримерИспользования()

    ' отключаем обновление экрана

    Application.ScreenUpdating = False

    ' считываем массив с листа - в него попадут все заполненные строки

    Массив = Range([A1], Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value

    ' объединяем уникальные, суммируя данные в столбцах 2 и 3

    arr = JoinedArray(Массив, 1, "2,3")

    Range("e:g").ClearContents    ' очистка содержимого столбцов E F G

    ' заносим массив на лист, начиная с ячейки e1

    Range("e1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

End Sub

• 17261 просмотр