Показать сообщение отдельно
Старый 12.04.2013, 18:55   Вверх   #396
ineegma
Мужской Продвинутый
 
Аватар для ineegma
 
Регистрация: 03.09.2008
Адрес: Москва
Макросом быстрее будет. Запускать на каждом отдельном листе:

Код:
Sub Sort_Goods_and_Sizes()

Dim totalrows, Row, i As Long

Application.ScreenUpdating = False

totalrows = ActiveSheet.UsedRange.Rows.Count

    Range(Cells(2, 1), Cells(totalrows, 2)).Sort Key1:=Cells(2, 1), Order1:=xlDescending, _
                                                 Key2:=Cells(2, 2), Order2:=xlDescending, _
                                                 Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
                                                 Orientation:=xlTopToBottom, _
                                                 DataOption1:=xlSortNormal, _
                                                 DataOption2:=xlSortNormal
For Row = totalrows To 3 Step -1

    If Cells(Row, 1) = Cells(Row - 1, 1) _
    And Cells(Row, 2) = Cells(Row - 1, 2) Then
    
        Rows(Row).EntireRow.Delete
        
    End If
    
Next Row

totalrows = ActiveSheet.UsedRange.Rows.Count

i = 1

For Row = totalrows To 2 Step -1

    If Cells(Row, 1) = Cells(Row - 1, 1) Then
    
        Cells(i, 3) = Cells(Row, 1)
        Cells(i, 4) = Cells(i, 4) & Cells(Row, 2) & ", "
        
    Else
    
        Cells(i, 3) = Cells(Row, 1)
        Cells(i, 4) = Cells(i, 4) & Cells(Row, 2)
        i = i + 1
    
    End If
    
Next Row

Columns(2).EntireColumn.Delete
Columns(1).EntireColumn.Delete

Application.ScreenUpdating = True

MsgBox "Done!"

End Sub

Последний раз редактировалось ineegma; 12.04.2013 в 19:00.
ineegma вне форума  
Конфигурация ПК
Ответить с цитированием