Помогите написать макрос

Автор fujica, 24 февраля 2019, 23:29

0 Пользователи и 1 гость просматривают эту тему.

JohnSUN

Это не страшно, что теперь одна и та же сумма будет участвовать в итогах по несколько раз?
Вот этот вариант немного смущает:
Цитата: fujica от 26 февраля 2019, 19:10
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

Если делить не надо, суммировать как и было написано, то как-то так:
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

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


fujica

Пример:
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

Работает!!!
Чтобы я без вас делал. Т_Т