Макросы в Excel

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