Страницы: 1
RSS
VBA - округление до целого по условию (короба округляем)
 
Уважаемые знатоки и любители Excel,    
 
Имею такую задачу:    
 
Таблица с данными по товару, количествам товара в штуках и кол-ву товара в пересчете на коробки. 1 артикул может повторяться в нескольких строках (т.к. у него есть разные доп. параметры (цвет).    
 
Выглядит так:    
 
Артикул \ Кол-во \ Короба  
111     \  5     \ 0.7  
111     \  3     \ 0.2  
111     \  1     \ 0.1  
Т.е. всего 1 коробка.    
 
Возникла необходимость отражать короба исключительно и только целыми числами, делая такое "виртуальное" распределение по коробам. Т.е. для некоторых строк, имеющих наибольшее кол-во проставлять целое число коробок, округляя его арифметически, а для остальных - проставлять просто 0  
Т.е. представлять таблицу в следующем виде:    
Артикул \ Кол-во \ Короба  
111     \  5     \ 1  
111     \  3     \ 0  
111     \  1     \ 0  
 
мне нужна помощь в реализации этой процедуры через VBA. Если у кого-то есть (возможно) примеры реализации аналогичной задачи, буду признателен.    
 
Пример (файл с парой-тройкой значений) прилагаю. Спасибо
 
Циклом проходить по каждому артикулу. Находить наибольшее значение и округлять его арифметически. Видимо, так буду делать. Но я не пойму, как заставить Эксель узнать, когда надо остановиться и перестать округлять (т.е. когда будет достигнуто общее необходимое кол-во коробов). Делать переменную, в которую писать общее кол-во и сравнивать с тем, что проставилось?
 
Пробуйте  
 
Sub Макрос1()  
Dim c As Range, a As Range, kor&  
With Columns("A:C")  
   .Sort Key1:=Range("A2"), Order1:=xlDescending, Key2:=Range("B2") _  
       , Order2:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:= _  
       False, Orientation:=xlTopToBottom  
   .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3), _  
       Replace:=True, PageBreaks:=False, SummaryBelowData:=False  
   For Each a In Range("B:B").SpecialCells(xlCellTypeConstants, xlNumbers).Areas  
       kor = a(1).Offset(-1, 1) 'число коробок данного артикула  
       For Each c In a.Offset(, 1).Cells  
           If kor > 0 Then  
               c = Application.Max(Round©, 1)  
               kor = kor - c  
           Else  
               c = 0  
           End If  
       Next  
   Next  
   .RemoveSubtotal  
End With  
End Sub  
 
Примечание: Макрос делает сортировку по ст. А и В, по убыванию. Если потом надо вернуть исходную последовательность записей - напишите, надо будет дополнить макрос.
 
Спасибо, Казанский. все ОК. сортировку и пр. чуть переделал под формат родного файла. В остальном - отлично все работает. Тема закрыта.
Страницы: 1
Читают тему
Наверх