Объдинить значения ячеек в одну строку по

[Newbay]

Здравствуйте уважаемые форумчане!

Понимаю что вопрос скорее всего для Вас довольно прост.Но для меня это оказалась не решимая задача т.к. опыта работы с либре или экселем нет как собственно и необходимости не было

Задача состоит вот в чем:
Есть файл со списком ссылок на изображения в одном столбце и номером ИД в другом столбце.Необходимо записать значения со столбца с ссылками в отдельный столбец через зпт(,)в одну строку, руководствуясь номером ИД.В основном это 2-5 ссылки,но есть и ИД с 14-ю ссылками(2192 ИД),как это сделать для 2х значений я разобрался а вот когда появилось большее количество формула перестала правильно работать и начала дублировать значения ячеек со ссылками.

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

Всем заранее большое спасибо и хорошего настроения!

Файл прилогаю.

[JohnSUN]

Добро пожаловать на форум, Newbay!
Знаешь, а тебе присвоен идентификатор 7777? С одной стороны - счастливое число, а с другой стороны - это же скольким пользователям мы здесь уже помогли!
Твоя задача, в принципе, не очень сложная - с формулами, конечно, пришлось бы повозиться, но макрос с такой задачей справляется довольно быстро. Ну, относительно быстро - всё-таки данных довольно много.
Хотелось бы уточнить - тебе нужно решить задачу для одной только этой книги? Или эту работёнку нужно будет проделывать регулярно?

[rami]

Была похожая тема Объединение текста в одну строку по условию.

[Newbay]

Спасибо большое за быстрый ответ,думаю необходимо будет делать регулярно,по форуму искал но не так задавал условия поиска:)
Тему сейчас изучу:)

[JohnSUN]

Да нет, тот способ хорош для не таких больших объёмов данных (я о нём тоже вспомнил, попробовал применить и успешно подвесил машину   )
Твой файл пришлось слегка кастрировать уменьшить - место на сервере не резиновое, большие файлы приходится время от времени удалять. Так что и твой исходный файл после закрытия темы тоже грохнем, не обессудь.
Но тот самый ID=2192 для наглядности оставил.
Текст макроса есть в книге, здесь его привожу просто чтобы не потерялся при очередной чистке сервера:

Код Выделить Развернуть

Option Explicit ' Все переменные объявляются явно через "Dim".
Option Base 0 ' Индексация каждого массива начинается с нуля

Sub shortList
Dim oSheet As Variant
Dim oCursor As Variant
Dim oSrcData As Variant
Dim oData As Variant
Dim oRes As Variant
Dim oDoc As Variant
Dim oProgrBar As Variant
Dim i As Long
oSheet = ThisComponent.getCurrentController().getActiveSheet()
REM Чтобы пользователь не заскучал, пока выполняется макрос, отобразим полоску прогресса
oProgrBar = ThisComponent.getCurrentController().getFrame().createStatusIndicator()

oCursor = oSheet.createCursor()
oCursor.gotoEndOfUsedArea(True)
oSrcData = oCursor.getDataArray()
REM Уже знаем, сколько приблизительно придется ждать
oProgrBar.start("Придется немного подождать...", UBound(oSrcData))
oRes = Array()
For i = LBound(oSrcData)+1 To UBound(oSrcData) ' +1 - строку заголовка пропускаем
If i Mod 100 = 0 Then oProgrBar.setValue(i)
oData = oSrcData(i)
FindAndAdd(oData(1), oData(0), oRes)
Next i
REM Еще раз пройдемся по массиву oRes и превратим массивы URL в "строку через запятую"
oProgrBar.End ' И опять знаем, сколько придется ждать
oProgrBar.start("Придется немного подождать...", UBound(oRes))
For i = LBound(oRes) To UBound(oRes)
oProgrBar.setValue(i)
oRes(i)(1) = Join(oRes(i)(1), ",")
Next i
oProgrBar.End
Rem Выведем получившийся массив в первый лист новой книги
putArrayToNewSheet(oRes, Array("ID","URLs"))
End Sub

Sub FindAndAdd(ID_key As Variant, URL As String, aData As Variant)
Dim l&, r&, m&, N&, i&, uB&
Dim aRow As Variant
   l = LBound(aData)
   r = UBound(aData) + 1
   N = r
   While (l < r)
       m = l + Int((r - l) / 2)
       If aData(m)(0) < ID_key Then
           l = m + 1
       Else
           r = m
       End If
   Wend
   If r = N Then ' Новый элемент в конце массива
       ReDim Preserve aData(0 To N)
       aData(N) = Array(ID_key, Array(URL))
   ElseIf aData(m)(0) = ID_key Then ' Уже есть такой ID, добавить URL к его списку
       aRow = aData(r)(1)
       uB = UBound(aRow) + 1
       ReDim Preserve aRow(uB)
       aRow(uB) = URL
       aData(r)(1) = aRow
Else ' Найдено место для нового ID в середине массива aData
       ReDim Preserve aData(0 To N)
       For i = N - 1 To r Step -1 ' Сдвинуть имеющиеся элементы к концу массива
           aData(i + 1) = aData(i)
       Next i
       aData(r) = Array(ID_key, Array(URL)) ' и вписать новый ID на его место
   End If
End Sub

Sub putArrayToNewSheet(a As Variant, Optional Headers As Variant)
Dim oDoc As Variant
Dim oSheet As Variant
Dim w As long, h As long
GlobalScope.BasicLibraries.LoadLibrary("Tools")
oDoc = CreateNewDocument("scalc")
oSheet = oDoc.getSheets().getByIndex(0)
w = UBound(a(0)) - LBound(a(0))
h = UBound(a) - LBound(a)
If IsMissing(Headers) Then
oSheet.getCellRangeByPosition(0, 0, w, h).setDataArray(a)
Else
oSheet.getCellRangeByPosition(0, 0, UBound(Headers),0).setDataArray(Array(Headers))
oSheet.getCellRangeByPosition(0, 1, w, h+1).setDataArray(a)
EndIf
End Sub

[Newbay]

Гениально!
Большое спасибо JohnSun,за ответ и спасибо Вашему форуму!

П.С. К сожелению пока нет возможности поблагодарить более существенно,но как буду в Украине обязательно это сделаю
!