Удалить дупликаты + ВПР и СЦЕПИТЬ через символ

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

Добрый день, коллеги!

Нуждаюсь в решении проблемы создания макроса.
Во вложении файл, вкладка был и стал.
По задумке после работы макроса из БЫЛ становится СТАЛ.

Мои раздумья меня привели к:
сначала рекордером удаляем дубликаты столба А и B, дальше...все, нужно ВПР и СЦЕПЛЯТЬ.

Жду помощи. Спасибо!

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

Или может как то формулами.......

[IgorGO]

Sub PrepareData()
  Dim dc As Object, r As Long, k As String, a1(), a2()
  Set dc = CreateObject("Scripting.Dictionary")
  For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    k = Cells(r, 1) & chr(9) & Cells(r, 2)
    If dc.exists(k) Then dc(k) = dc(k) & "." & Cells(r, 3) Else dc.Add k, Cells(r, 3)
  Next
  a1 = dc.Keys
  ReDim a2(0 To dc.Count - 1)
  For r = 0 To dc.Count - 1
    a2(r) = Split(a1(r), chr(9))(1)
    a1(r) = Split(a1(r), chr(9))(0)
  Next
  With Worksheets(Worksheets.Count)
    .Cells(2, 1).Resize(dc.Count, 1).Value = WorksheetFunction.Transpose(a1)
    .Cells(2, 3).Resize(dc.Count, 1).Value = WorksheetFunction.Transpose(a2)
    .Cells(2, 3).Resize(dc.Count, 1).Value = WorksheetFunction.Transpose(dc.items)
  End With
End Sub

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

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

Sub PrepareData()
  Dim dc As Object, r As Long, k As String, a1(), a2()
  Set dc = CreateObject("Scripting.Dictionary")
  For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    k = Cells(r, 1) & chr(9) & Cells(r, 2)
    If dc.exists(k) Then dc(k) = dc(k) & "." & Cells(r, 3) Else dc.Add k, Cells(r, 3)
  Next
  a1 = dc.Keys
  ReDim a2(0 To dc.Count - 1)
  For r = 0 To dc.Count - 1
    a2(r) = Split(a1(r), chr(9))(1)
    a1(r) = Split(a1(r), chr(9))(0)
  Next
  With Worksheets(Worksheets.Count)
    .Cells(2, 1).Resize(dc.Count, 1).Value = WorksheetFunction.Transpose(a1)
    .Cells(2, 3).Resize(dc.Count, 1).Value = WorksheetFunction.Transpose(a2)
    .Cells(2, 3).Resize(dc.Count, 1).Value = WorksheetFunction.Transpose(dc.items)
  End With
End Sub

Привет, IgorGO. Спасибо за помощь в решении.

Есть несколько вопросов.

Запускаю макрос с листа (БЫЛ), но как-то некорректно он "пилит" диапазоны. Пустой столб "B" + в "C" что-то через запятую, а чтото через точку... непонятно, может я чтото не так делаю?

[IgorGO]

есть несколько ответов:
пустой столбец В из-за опечатки в строке

.Cells(2, 2).Resize(dc.Count, 1).Value = WorksheetFunction.Transpose(a2)

точки, запятые в колонке С - это проблема порождена принятым Вами способом разделить значения точками.
когда в словарь попадает значение 1.2, а потом это значение выкладывается в ячейку - эксель решает что 1.2 - это число одна целая две десятых, и записывает в ячейку число (у Вас в системе разделитель дробной и целой части, видимо, запятая, вот и появляются запятые, там где было обьеденено ровно 2 значения), а например 1.2.3 - это не число поэтому именно в таком виде оно и отображается в ячейке (хотя 1.2.3 ексель еще мог воспринять как дату 1 февраля 2003 года, просто у вас там числа 5000.5000.5000 - это на дату не похоже)
вместо точки сделайте разделитель пробел - все станет на свои места

удачи!

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

Понял в чем проблема, решил ее разделением через "_", а потом макросом заменяю массово "_" на "."

Нарисовалась новая проблема

Есть какое-то ограничение на сцепку? Во вложении "рабочие" числа и когда значения "которые сцепляем" (выделены желтым) - "прогоняем" через макрос - выдает ошибку.

В чем может быть проблема?

[IgorGO]

Sub PrepareData()
  Dim dc As Object, r As Long, k As String, a1(), a2()
  Set dc = CreateObject("Scripting.Dictionary")
  For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    k = Cells(r, 1) & Chr(9) & Cells(r, 2)
    If dc.exists(k) Then dc(k) = dc(k) & "_" & Cells(r, 3).Value Else dc.Add k, Cells(r, 3).Value
  Next
  a1 = dc.Keys:  ReDim a2(1 To dc.Count, 1 To 3)
  For r = 1 To dc.Count
    a2(r, 1) = Split(a1(r - 1), Chr(9))(0)
    a2(r, 2) = Split(a1(r - 1), Chr(9))(1)
    a2(r, 3) = dc(a1(r - 1))
  Next
  Worksheets(Worksheets.Count).Cells(2, 1).Resize(dc.Count, 3).Value = a2
  ' Application.Run "to4ka"
End Sub