Сортировка с копированием VBA

[bugx]

Подскажите, а вернее необходимо написать макрос такой вот сортировки.
На листе один имеется наименование товара, код, количество.
Код товара периодически повторяется. Необходимо при нажатии на кнопку, в листе2 создавалась такая же таблица, только чтобы были уникальные записи по коду и сумма количества.

[Hugo121]

Тут есть готовое решение-полуавтомат:
http://www.planetaexcel.ru/forum/ind...ID=8&TID=24401

[bugx]

Вот есть такой код:

Sub ss()
Dim a(), oDict As Object, i As Long, temp As String
a = Range("B1:C" & Range("B" & Rows.Count).End(xlUp).Row).Value
Set oDict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a)
temp = UCase(Trim(a(i, 1)))
If Not oDict.Exists(temp) Then
oDict.Add temp, CStr(a(i, 2))
Else
oDict.Item(temp) = CStr(--oDict.Item(temp) + a(i, 2))
End If
Next
With ThisWorkbook.Worksheets(2)
.Range("B1").Resize(oDict.Count) = Application.Transpose(oDict.keys)
.Range("C1").Resize(oDict.Count) = Application.Transpose(oDict.items)
End With
End Sub

Все работает как надо. Проблема в том, что мне необходимо для трех столбцов. Т.е. чтобы первый столбец был привязан к конкретному номеру во втором столбце. Прошу прощения за банальный вопрос, но я не когда не работал с ВБА. И разобраться в коде для мне большая проблема на данный момент, вот по этому и прошу помощи гуру.



___________
Код нужно оформлять по правилам:
тегом [CODE]..[/СODE]
(кнопочка на панели форматирования с решёточкой #)
Не забывайте об этом!
Модератор.

[IgorGO]

видимо надо так поправить

With ThisWorkbook.Worksheets(2)
  .cells.clearcontents
  .Range("B1").Resize(oDict.Count) = Application.Transpose(oDict.keys)
  .Range("C1").Resize(oDict.Count) = Application.Transpose(oDict.items)
  dim r as long, rg as range
  r = 1
  do while .cells(r,2) <> ""
    set rg = range("B:B").find(.cells(r,2))
    .cells(r,1) = rg.offset(0,-1)
    r = r+1
  loop
End With

[bugx]

чего то не то получилось. Первый столбец остается все равно не заполнен. Попробую еще раз объяснить. В столбце А - название продукции, в столбце В - код продукта, в столбце С - количество. Мне необходимо сделать уникальные записи в столбце В и просуммировать количество повторяющихся в столбце С. Но чтобы запись в столбце А, которой соответствует код в столбце В остались. Получается повторяющиеся удаляются. Прикрепленный файл в начале топика.

[bugx]

Немного поправил код:

With ThisWorkbook.Worksheets(2)
  .Cells.ClearContents
  .Range("B1").Resize(oDict.Count) = Application.Transpose(oDict.keys)
  .Range("C1").Resize(oDict.Count) = Application.Transpose(oDict.items)
  Dim r As Long, rg As Range
  r = 1
  Do While .Cells(r, 2) <> "A"
    Set rg = Range("B:B").Find(.Cells(r, 2))
    .Cells(r, 1) = rg.Offset(0, -1)
    r = r + 1
  Loop
End With

Программа зацикливается, но если ее прервать, вроде работает как надо.

[IgorGO]

не проверял на данных, писал просто тут, поэтому:
вместо r = 1 напишите r = 2
выход из цикла все-таки по достижению пустой ячейки в колонке 2 (а не ячейки с буквой А)))
Do While .Cells(r, 2) <> ""
так пробуйте:

    r = 2
    Do While .Cells(r, 2) <> ""

все пойдет

[bugx]

ушел от зацикливания. Не самый лучший код, но для человека, который только что открыл для себя VBA сойдет

With ThisWorkbook.Worksheets(2)
  .Cells.ClearContents
  .Range("B1").Resize(oDict.Count) = Application.Transpose(oDict.keys)
  .Range("C1").Resize(oDict.Count) = Application.Transpose(oDict.items)
  Dim r As Long, rg As Range
  r = 1
  Do
      r = r + 1
  '.Cells(r, 2) <> "A"'
    Set rg = Range("B:B").Find(.Cells(r, 2))
    .Cells(r, 1) = rg.Offset(0, -1)
    Loop Until r = 5000
  'Loop'
End With

Единственный недостаток это обработка столбца в 5000 ячеек. Если ставить по максимуму 65535, думает очень долго. Так что для меня 5000 ячеек выше-крыши

[bugx]

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

не проверял на данных, писал просто тут, поэтому:
вместо r = 1 напишите r = 2
выход из цикла все-таки по достижению пустой ячейки в колонке 2 (а не ячейки с буквой А)))
Do While .Cells(r, 2) <> ""
так пробуйте:

    r = 2
    Do While .Cells(r, 2) <> ""

все пойдет

ваш код работает на ура, я просто допустил ошибку в формирование первоначальной таблицы. Просто первая строчка у меня была пустой. Не стал изменять переменную r на двойку а просто изменил структуру таблицы, убрав первую пустую ячейку. Спасиб большое. Но и на примере моего кода, я немного въехал в суть

[IgorGO]

Но и на примере моего кода, я немного въехал в суть

а вот это абсолютно правильный вывод! То, что написали сами - возможно не совсем правильно, на самым рациональным способом, но сделано это осознано и если заработало - уже хорошо, цель достигнута.