mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Объединение строк в двумерном массиве

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

функция получает в качестве параметров исходный массив, и номер столбца 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

ВложениеРазмерЗагрузкиПоследняя загрузка
JoinedArray.xls870 КБ5725 недель 3 дня назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Здравствуйте!
А как считать данные в массив начиная не с первой строки, а, например, с 5;
и не зная, в какой строке заканчиваются данные?

Здравствуйте, Петр
Надо немного доработать функцию. Если готовы оплатить доработку - могу сделать (обращайтесь в скайп или на почту)

Как сделать чтобы при выполнении данной функции столбцы, указанные в переменной ColumnsForJoin соединялись через разделитель JoinSeparator, только если они не одинаковые, а если одинаковые, то значение указывалось только один раз?

Использую функцию чтобы собрать с нескольких листов информацию о товарах (Модель; Описание; Фирма; Цена, руб.; Кол., шт.; Сумма, руб.; Примечания)
По столбцу Модель ищу уникальные
По столбцу Кол., шт. суммирую
По столбцам Описание; Фирма; Цена, руб.; Примечания соединяю

Затем хочу увидеть строки, которые отличаются по столбцам Описание; Фирма; Цена, руб.; Примечания и вручную поправить значения.

Возможные причины ошибки:
1) массив пустой
2) количество строк в массиве больше количества строк на листе
3) в массиве содержатся значения, начинающиеся со знака = (но не являющиеся корректными формулами)
4) лист защищён, или активная книга отсутствует

PS: возможны и другие причины

Здравствуйте! Помогите пожалуйста. Пытаюсь использовать пример для склеивания текстовых значений. При выводе результата получаю ошибку на строке
Range("e1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
В чем может быть дело?

Екатерина, так к статье ведь прикреплён файл с примером использования...

А у кого-нибудь есть пример эксель файла чтобы посмотреть как работает? Заранее спасибо

Все, разобралась, большое спасибо!

Извините, наверное неправильно выразилась. Суммировать значения не нужно, необходимо объединить в одну строку значения через запятую в столбцах 2,3. Параметры функции заданы так:
arr = JoinedArray(Массив, 1, " ", "2,3")
При пошаговом выполнении макроса видно, что строка
' заносим массив на лист, начиная с ячейки e1
Range("e1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
все значения заносит правильно, но дальше при выполнении строк макроса
' пишем формулу в столбец H (сразу во все ячейки)
Range("h1").Resize(UBound(arr, 1)) = "=rc[-1]+rc[-2]"
' заменяем формулы значениями
Range("h1").Resize(UBound(arr, 1)).Value = Range("h1").Resize(UBound(arr, 1)).Value
в столбце Н выдается ошибка #ЗНАЧ!. Если я правильно понимаю, то выражение "=rc[-1]+rc[-2]" здесь не подходит? Помогите пожалуйста правильно написать эти две строки макроса для объединения значений в столбце Н . Спасибо.

Я не совсем понял, что значит «объединение символьных значений»
В параметрах функции можно задать как столбцы для суммирования, так и (в другом параметре) столбцы для объединения (склеивания текстовых значений через заданный разделитель)

Здравствуйте! У Вас пример именно для суммирования числовых значений. Если в строках символьные значения, то через запятую макрос их не выводит. Пожалуйста, объясните как заменить эти две строки кода именно для объединения символьных значений:
Range("h1").Resize(UBound(arr, 1)) = "=rc[-1]+rc[-2]"
Range("h1").Resize(UBound(arr, 1)).Value = Range("h1").Resize(UBound(arr, 1)).Value
Большое спасибо.

Работает Спасибо!

Здравствуйте, Денис.

Сначала пробегаете в цикле по массиву, формируя в доп. столбце уникальной значение путем объединения данных из 1 и 4 столбцов:

    For i = LBound(Массив) To UBound(Массив)
        Массив(i, 10) =  Массив(i, 1) & "\\" &  Массив(i, 4)
    Next i

а потом по 10 столбцу объединяете:
arr = JoinedArray(Массив, "10", "2,3", "5,8,9")

Возможно ли сдлеть фильтр уникальных по двум столбцам 1 и 4?
arr = JoinedArray(Массив, "1,4", "2,3", "5,8,9")
Я так понимаю что нет, а какую функцию можно использовать для фильтрации по двум столбцам и суммирования остальных?

Спасибо

Тут правило простое: если не знаешь, как объявить переменную, - объяви её с типом Variant.
Например:

On Error Resume Next
Dim i, j, col, nCol 
' и т.д.

Доброго времени суток.
Подскажи пожалуйста как правильно будет объявить переменные для данной функции и примера использования, если использовать Option Explicit?
Спасибо

спасибо за вразумительный ответ, а то моя голова была бы совсем сломана дальнейшими безуспешными попытками объединения диапазонов с разных листов)))

Вы путаете понятия "массив" и "диапазон ячеек". Это совершенно разные вещи.
Моя функция работает с массивами. Массив - это набор значений в памяти компьютера, безотносительно к каким-либо ячейкам или листам.
И функции неважно, откуда взят этот массив, - главное, чтобы он был двумерным.

Массив не может находиться на листе Excel.
На листе Excel может быть диапазон ячеек, а вот значения из этого диапазона ячеек могут быть считаны в массив.

То, что пытаетесь сделать вы - при помощи Union(лист1.массив;лист2.массив), в принципе работать не будет.
И виновата в этом не моя функция, а неверное использование функции Union:
Нельзя объединять диапазоны с разных листов:

Sub test()
    Dim ra As Range: Set ra = Union(Лист1.[a1:d5], Лист2.[a1:d5])
End Sub

Даже если бы вы каким-то образом объединили 2 диапазона ячеек, то моя функция не смогла бы обработать результат,
поскольку результатом был бы не двумерный массив, а массив массивов.

Совет:
1) в цикле считайте данные с каждого листа в массив
2) объедините все массивы в один при помощи функции CombineArrays
http://excelvba.ru/code/CombineArrays
3) результат поместите на нужный лист

Здравствуйте! Поправьте если ошибаюсь: функция работает только если исходный массив и преобразованный находятся на одном листе. Есть ли возможность использовать в качестве исходного массива - Union(лист1.массив;лист2.массив) а преобразованный поместить на лист3 ?

Так пробовали?

  ' объединяем уникальные, суммируя данные по столбцам 2 и 3,
  ' и соединяя данные через запятую в столбцах 5, 8 и 9
   arr = JoinedArray(Массив, 1, "2,3", "5,8,9")

Через запятую значения не расставляет. Как добиться этого?

Этот макрос не предназначен для таких больших массивов.
А тысячами строк он работает нормально, и даже ни десятках тысяч строк его можно применять (хотя, пожалуй, он будет подтормаживать)
А в вашем случае (сотни тысяч строк) надо применять совершенно другие алгоритмы обработки.
Могу посоветовать использовать встроенные средства Excel
(поскольку и версия Excel у вас не ниже 2007-й, да и массbm изначально ни листе находится)

Пытаюсь загнать диапазон в массив Массив = Range("A2:L359731").Value
В ответ получаю "аут оф мемори"

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _       _            __        __  ____   __  __
| | | | __ __ __ \ \ / / | _ \ \ \/ /
| | | |/ / \ \/ / \ \ /\ / / | |_) | \ /
| |___ | < > < \ V V / | _ < / \
|_____| |_|\_\ /_/\_\ \_/\_/ |_| \_\ /_/\_\
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.