ОБЬЕДЕНИТЬ, СЦЕПИТЬ И РАМКУ

[Евгений Таб]

Коллеги, приветствую!

На листе есть множесвтаво данных. Во вложении "кусок" листа по которому можно прикрутить макрос.

Дано :

Столбы R, S и T.

Необходимо :
Добавить столб "U" и наполнить его данными по примеру.
Обьединить сцепить и рамку....

Голову сломал.... Выручайте...

Спасибо!

[IgorGO]

Sub MergeCod()
  Dim r As Long, cnt As Long, i As Long, rg As Range, dct As Object
  Columns("u").Insert
  With Columns("u")
    .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = True
  End With
  Set dct = CreateObject("Scripting.Dictionary"):  r = 2
  Do While Not IsEmpty(Cells(r + 2, 19))
    cnt = IIf(IsEmpty(Cells(r + 1, 19)), 1, Cells(r, 19).End(xlDown).Row - r + 1)
    Cells(r, 21).Resize(cnt, 1).MergeCells = True
    For i = r To r + cnt - 1
      If Not IsEmpty(Cells(i, 20)) Then
        If Not dct.exists(Cells(i, 20).Value) Then dct.Add Cells(i, 20).Value, i
      End If
    Next
    Cells(r, 21) = Join(dct.keys, " ")
    For i = 7 To 10
      With Cells(r, 21).Resize(cnt, 1).Borders(i)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .Weight = xlMedium
      End With
    Next
    r = r + cnt + 1: dct.RemoveAll
  Loop
End Sub

[Евгений Таб]

Маленькие пилит таблички, с побольше не справился.......

Вложение............

Ps страна может быть не только Россия...

[IgorGO]

размер таблички для предложенного макроса - не критичен, критично чтобы сохранялась структура данных.
задача поставлнена визуально. как увидел - так решил. а вариантов может быть много, угадывать что там может быть - не интересно

[Евгений Таб]

Сообщение от IgorGO

размер таблички для предложенного макроса - не критичен, критично чтобы сохранялась структура данных.
задача поставлнена визуально. как увидел - так решил. а вариантов может быть много, угадывать что там может быть - не интересно

Подскажите тогда, оч прошу, что не так в моей новой большой табличке....
Ведь структура сохранена и логика тоже...

[IgorGO]

строка где было

  Do While Not IsEmpty(Cells(r + 2, 19))

оставляете просто

  Do

а строка, где было

  Loop

записываете как

  Loop Until IsEmpty(Cells(r, 19))

[Евгений Таб]

Сообщение от IgorGO

строка где было

  Do While Not IsEmpty(Cells(r + 2, 19))

оставляете просто

  Do

а строка, где было

  Loop

записываете как

  Loop Until IsEmpty(Cells(r, 19))

Мерси вам огромедное