Есть исходная tabl1 (строк может быть более 50 000). Можно ли макросом найти средневзвешенное значение "Р.цены" для каждого уникального значения "ОПТ" отдельно для сумм положительных и отрицательных объёмов и отобразить эти значения, создав tabl5.
Есть исходная tabl1 (строк может быть более 50 000). Можно ли макросом найти средневзвешенное значение "Р.цены" для каждого уникального значения "ОПТ" отдельно для сумм положительных и отрицательных объёмов и отобразить эти значения, создав tabl5.vlavaden
Public Function Opt(RR As Range, N As Long) As Variant Dim A() As Long ReDim A(1 To RR.Rows.Count) For Each R In RR Found = False For i = 1 To Counter If R.Value = A(i) Then Found = True Exit For End If Next i If Not Found Then Counter = Counter + 1 A(Counter) = R.Value End If Next R
l = 1
For i = (l + 1) To Counter buf = A(i) j = i - 1 Do While (A(j) < buf) A(j + 1) = A(j) j = j - 1 If j < l Then Exit Do Loop A(j + 1) = buf Next i
If N > Counter Then Opt = "" Else: Opt = A(Counter - N + 1) End If
Public Function Opt(RR As Range, N As Long) As Variant Dim A() As Long ReDim A(1 To RR.Rows.Count) For Each R In RR Found = False For i = 1 To Counter If R.Value = A(i) Then Found = True Exit For End If Next i If Not Found Then Counter = Counter + 1 A(Counter) = R.Value End If Next R
l = 1
For i = (l + 1) To Counter buf = A(i) j = i - 1 Do While (A(j) < buf) A(j + 1) = A(j) j = j - 1 If j < l Then Exit Do Loop A(j + 1) = buf Next i
If N > Counter Then Opt = "" Else: Opt = A(Counter - N + 1) End If
Ну и, если чистку дубликатов и сортировку вынести из функции в процедуру и выполнять ее только один раз, то тоже можно резко ускориться. Надо?abtextime
Не знаю, насколько всё глобально правильно, но на Вашем примере работает.
Решение с процедурой на Листе3
Макрос подвешен на Ctrl+q
[vba]
Код
Public Sub OptSub() Dim A(1 To 1000) As Double For Each R In ActiveSheet.ListObjects("tabl148").ListColumns(1).Range Found = False For i = 1 To Counter If R.Value = A(i) Then Found = True Exit For End If Next i If Not Found And IsNumeric(R.Value) Then Counter = Counter + 1 A(Counter) = R.Value End If Next R
l = 1
For i = (l + 1) To Counter buf = A(i) j = i - 1 Do While (A(j) < buf) A(j + 1) = A(j) j = j - 1 If j < l Then Exit Do Loop A(j + 1) = buf Next i
For i = 1 To Counter ActiveSheet.ListObjects("tabl559").Range.Cells(2 * i, 1).Value = A(Counter - i + 1) ActiveSheet.ListObjects("tabl559").Range.Cells(2 * i + 1, 1).Value = A(Counter - i + 1) Next i
End Sub
[/vba]
Не знаю, насколько всё глобально правильно, но на Вашем примере работает.
Решение с процедурой на Листе3
Макрос подвешен на Ctrl+q
[vba]
Код
Public Sub OptSub() Dim A(1 To 1000) As Double For Each R In ActiveSheet.ListObjects("tabl148").ListColumns(1).Range Found = False For i = 1 To Counter If R.Value = A(i) Then Found = True Exit For End If Next i If Not Found And IsNumeric(R.Value) Then Counter = Counter + 1 A(Counter) = R.Value End If Next R
l = 1
For i = (l + 1) To Counter buf = A(i) j = i - 1 Do While (A(j) < buf) A(j + 1) = A(j) j = j - 1 If j < l Then Exit Do Loop A(j + 1) = buf Next i
For i = 1 To Counter ActiveSheet.ListObjects("tabl559").Range.Cells(2 * i, 1).Value = A(Counter - i + 1) ActiveSheet.ListObjects("tabl559").Range.Cells(2 * i + 1, 1).Value = A(Counter - i + 1) Next i
Уважаемый abtextime, макрос прекрасно работает, вот только формула для нахождения средневзвешенного значения не верна. Вы не могли бы исправить? Пример в файле.
Уважаемый abtextime, макрос прекрасно работает, вот только формула для нахождения средневзвешенного значения не верна. Вы не могли бы исправить? Пример в файле.vlavaden
хоть и много места в формуле занимает, но зато заранее отсекает все нулевые значения, что на Вашем объеме важно - СУММПРОИЗВ не так быстра, как СУММЕСЛИ
В столбце J формат ячеек 0,00;-0,00; - нули не видны Можно и так 0,00;;
хоть и много места в формуле занимает, но зато заранее отсекает все нулевые значения, что на Вашем объеме важно - СУММПРОИЗВ не так быстра, как СУММЕСЛИ
В столбце J формат ячеек 0,00;-0,00; - нули не видны Можно и так 0,00;;_Boroda_