Форум поддержки пользователей. LibreOffice, Apache OpenOffice, OpenOffice.org

Форум поддержки пользователей. LibreOffice, Apache OpenOffice, OpenOffice.org

18 Июнь 2019, 09:59 *
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
Вам не пришло письмо с кодом активации?

Войти
Новости: Доступно и просто о работе в офисных пакетах
 
   Начало   Помощь Поиск Войти Регистрация    задать вопрос  
Страниц: « 1 2   Вниз
  Печать  
Автор Тема: Помогите написать макрос  (Прочитано 2237 раз)
0 Пользователей и 1 Гость смотрят эту тему.
JohnSUN
Капитана в тот день называли на "ты"
Гуру
*******
Offline Offline

Пол: Мужской
Расположение: Киев
Сообщений: 2 764


Помогаю людям и компьютерам понимать друг друга


WWW
« Ответ #15: 26 Февраль 2019, 20:17 »

Это не страшно, что теперь одна и та же сумма будет участвовать в итогах по несколько раз?
Вот этот вариант немного смущает:
12,53№1-яблоки;
45,6№3-проезд;
100№1№3-ресторан;

SUM_OF_GROUP(А1;1)=112,53
SUM_OF_GROUP(А1;3)=145,6
Может всё-таки
Код:
SUM_OF_GROUP(А1;1)=62,53
SUM_OF_GROUP(А1;3)=55,6
В смысле - раскидать поровну по каждой из групп?
Записан

Владислав Орлов aka JohnSUN
Благодарить-не зазорно.
Подарить благо создателям офиса, нашему ресурсу, мне
JohnSUN
Капитана в тот день называли на "ты"
Гуру
*******
Offline Offline

Пол: Мужской
Расположение: Киев
Сообщений: 2 764


Помогаю людям и компьютерам понимать друг друга


WWW
« Ответ #16: 26 Февраль 2019, 20:50 »

Если делить не надо, суммировать как и было написано, то как-то так:
Код:
Function SUM_OF_GROUP(ByVal sText As String, numGroup As Variant, Optional sSeparator As Variant) As Double
If IsMissing(sSeparator) Then sSeparator = "№"
SUM_OF_GROUP = 0
On Error Resume Next
SUM_OF_GROUP = binFind (numGroup, getGroups(sText, sSeparator))
End Function

Function getGroups(ByVal sText As String, sSeparator As Variant) As Variant
Dim aRes As Variant, aRows As Variant, aNums As Variant, aGroups As Variant
Dim sNum As String, dVal As Double
Dim i As Long, j As Long, lastRow As Long
aRes = Array()
lastRow = -1
sText = Replace(sText, Chr(13), Chr(10))
Do While InStr(sText, Chr(10) & Chr(10)) > 0
sText = Replace(sText, Chr(10) & Chr(10), Chr(10))
Loop
aRows = Split(sText, Chr(10))
For i = LBound(aRows) To UBound(aRows)
aNums = Split(aRows(i),"-")
If UBound(aNums)>0 Then
aGroups = Split(aNums(0),sSeparator)
If UBound(aGroups)>0 Then
dVal = Val(Replace(aGroups(0),",","."))
For j = 1 To UBound(aGroups)
countUniq(Val(aGroups(j)), aRes, dVal)
Next j
EndIf
EndIf
Next i
getGroups = aRes
End Function

Sub countUniq(ByVal key As Variant, ByRef aData As Variant, ByVal dVal As Double)
Dim l&, r&, m&, N&, i&
    l = LBound(aData)
    r = UBound(aData) + 1
    N = r
    While (l < r)
        m = l + Int((r - l) / 2)
        If aData(m)(0) < key Then
            l = m + 1
        Else
            r = m
        End If
    Wend
    If r = N Then
        ReDim Preserve aData(0 To N)
        aData(N) = Array(key, dVal)
    ElseIf aData(r)(0) = key Then
aData(r)(1) = aData(r)(1) + dVal
    Else
        ReDim Preserve aData(0 To N)
        For i = N - 1 To r Step -1
            aData(i + 1) = aData(i)
        Next i
        aData(r) = Array(key, dVal)
    End If
End Sub

Function binFind(key, aData) As Double
Dim l&, r&, m&, N&
l=LBound(aData)
r=UBound(aData)+1
N=r
While (l<r)
m=l+Int((r-l)/2)
If aData(m)(0)<key Then
l=m+1
Else
r=m
EndIf
Wend
If r=N Then
binFind = 0
ElseIf  aData(r)(0)=key Then
binFind = aData(r)(1)
Else
binFind = 0
EndIf
End Function
Записан

Владислав Орлов aka JohnSUN
Благодарить-не зазорно.
Подарить благо создателям офиса, нашему ресурсу, мне
fujica
Участник
**
Offline Offline

Сообщений: 17


« Ответ #17: 26 Февраль 2019, 21:45 »

Всё правильно.
Одна и та же сумма может участвовать несколько раз.

« Последнее редактирование: 26 Февраль 2019, 21:47 от fujica » Записан
fujica
Участник
**
Offline Offline

Сообщений: 17


« Ответ #18: 26 Февраль 2019, 21:49 »

Пример:
12,53№1-яблоки; {еда}
36.2№2-ручки; {вещи}
45,6№3-проезд; {не материальное}
100№1№3-ресторан; {и еда и развлечение(не материальное)}

SUM_OF_GROUP(А1;1)=112,53
SUM_OF_GROUP(А1;2)=36.2
SUM_OF_GROUP(А1;3)=145,6

Записан
fujica
Участник
**
Offline Offline

Сообщений: 17


« Ответ #19: 26 Февраль 2019, 21:56 »

Работает!!!
Чтобы я без вас делал. Т_Т
Записан
Страниц: « 1 2   Вверх
  Печать  
 
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2009, Simple Machines Valid XHTML 1.0! Valid CSS!