Excel: Макрос для сборки данных

[iva]

Здравствуйте!
Пожалуйста, помогите решить мою задачу. Нужен макрос, который бы собирал данные с листа на новый лист по образцу во вложении.

[вложение удалено администратором]

[Администратор]

Для одной модели в столбцах G, R, S одни и те же данные всегда? Например в столбце F несколько данных.

[iva]

Да, данные всегда одинаковые по модели, кроме столбца F.

[Администратор]

Нужно создавать новый лист? Или нужно копировать данные в уже имеющийся лист?

[iva]

на новый лист

[Администратор]

А зачем единицы нужны в столбце A?

[iva]

Автоматически формируются при выгрузке из какой-то программы. Как я понимаю, они идут между группами ID.

[Администратор]

И в столбце B данные отсортированы по алфавиту всегда?

[iva]

Нет. Порядок произвольный. И в столбце А, и в В.

[Администратор]

Можно ведь ориентироваться на столбец M - там всегда будут объединённые ячейки?
Строки, которые имеют одну объединённую ячейку в столбце M относятся к одной группу и эти строки нужно объединить.

[Администратор]

Внутри группы данные в столбце B одинаковые?

[iva]

Да, в столбце М строки, которые имеют объединенную ячейку относят к одной группе (если не считать, что они захватывают и пустые строки, с единицамив столбце А. Их учитывать в сборке не надо).
Для ориентации - столбец А как и столбец В уникальны. Внутри А (и В) одинаковые группы соответственно. По ним можно ориентироваться для объединения.

Да, внутри группы данные в столбце В одинаковые.

[Администратор]

Здесь две процедуры. Поместите их в один модуль. Запускайте процедуру "Макрос", вторая процедура будет запускаться процедурой "Макрос".
В файле должен быть лист-шаблон. Макрос на его основе создаёт новый лист. Лист-шаблон можно скрыть. Макрос копирует оформление из второй строки во все остальные.

Макрос. Версия от 29.03.2017 23:28

Sub Макрос()

    Dim shSrc As Worksheet, shRes As Worksheet, res()
    Dim lr As Long
   
   
    '1. Отключение монитора, чтобы ускорить работу макроса и чтобы не мерцало.
    Application.ScreenUpdating = False
   
    '2. Присваивание имени листу-источнику.
    Set shSrc = Worksheets("исходный")
   
    '3. Отображение скрытых строк, чтобы найти последнюю строку.
        ' Метод End не ищет в скрытых строках.
    If shSrc.AutoFilterMode = True Then
        shSrc.AutoFilter.ShowAllData
    End If
    shSrc.Rows.Hidden = False
   
    '4. Обработка данных. Обработанные данные запишутся в массив "res".
    Process shSrc, res()
   
    '5. Создание листа-результата. Учитывается, если лист-шаблон будет скрыт.
    ' Копирование перед, а не сразу после, т.к. если есть скрытые листы,
        ' то потом сложно найти вставленный лист - нужно анализировать скрытые листы.
    Worksheets("шаблон").Copy Before:=shSrc
    Set shRes = shSrc.Previous
    shRes.Visible = True
    shRes.Move After:=shSrc
    ' Ошибка будет, если уже есть лист с таким именем.
    On Error Resume Next
        shRes.Name = "Результат"
    On Error GoTo 0
   
    '6. Вставка массива "res" на лист-результат.
    shRes.Range("A2").Resize(UBound(res, 1), 6).Value = res()
   
    '7. Копирование оформления из строки 2 во все остальные строки.
    lr = shRes.UsedRange.Rows.Count
    If lr > 2 Then
        shRes.Rows(2).Copy
        shRes.Rows("2:" & lr).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        shRes.Range("A1").Select
    End If
   
    '8. Вкл. монитора.
    Application.ScreenUpdating = True
   
End Sub

Private Sub Process(shSrc As Worksheet, res())

    ' Обработка данных.
   
    Dim src(), lr As Long, i As Long, r As Long
   
   
    '1. В столбце B удаление повторов, в столбце F объединение данных в одну ячейку.
    ' Копирование данных в массив. С массивом быстрее работать, чем с эксель-ячейками.
    lr = shSrc.Cells(shSrc.Rows.Count, "B").End(xlUp).Row
    src() = shSrc.Range("A1:S" & lr).Value
   
    ' В столбце B удаление повторов, в столбце F объединение данных в одну ячейку.
    For i = UBound(src, 1) To 3 Step -1
        If src(i, 2) = src(i - 1, 2) Then
            src(i, 2) = Empty
            src(i - 1, 6) = src(i - 1, 6) & ";" & src(i, 6)
        End If
    Next i
   
    '2. Копирование данных из массива "src" в массив "res".
        ' Копируются только те строки, у которых не пусто в столбце B.
    ' Создание ячеек в массиве-результате.
        ' Создаётся максимально возможное кол-во строк, т.к. заранее не известо, сколько будет данных.
    ReDim res(1 To UBound(src, 1), 1 To 6)
    For i = 2 To UBound(src, 1)
        If src(i, 2) <> "" Then
            r = r + 1
            res(r, 1) = src(i, 2)
            res(r, 2) = src(i, 6)
            res(r, 3) = src(i, 7)
            res(r, 4) = src(i, 13)
            res(r, 5) = src(i, 18)
            res(r, 6) = src(i, 19)
        End If
    Next i

End Sub

[свернуть]

[вложение удалено администратором]

[iva]

Спасибо. Работает, но есть ошибка.

    '6. Вставка массива "res" на лист-результат.
    shRes.Range("A2").Resize(UBound(res, 1), 6).Value = res()

Есть ли ограничение на количество знаков, помещаемых на лист-результат в столбец В (где выполнено объединение)?
Насколько я вижу, максимально помещается 904 знака. А если требуется больше, то появляется эта ошибка.

[Администратор]

Какой текст ошибки?