Страницы: 1 2 След.
RSS
Суммирование значений в несвязанном диапазоне без дублирования пересекающихся ячеек
 
В ходе решения https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=104691&a... столкнулся с неприятной проблемой при работе с несвязанными диапазонами: "Если areas внутри диапазона пересекаются, то пересекающиеся ячейки дублируются при суммировании".
В экселе это выглядит вот так.

В vba фактически происходит то же самое. Формула СУММ выделенных диапазонов выдаёт 4 из-за того, что все они пересекаются в ячейке G10.

Как можно это обойти? Как получить корректную сумму этого диапазона? Я пробовал загонять значения всех ячеек в массив, но это топорно+медленно при большом диапазоне.

В идеале - нужно преобразовать несвязанный диапазон в другой несвязанный диапазон, в котором не будет пересечений между Areas, но у меня нет идей как это сделать, причём быстро.

В примере файлик с кусочком кода, который формирует и выделяет показанный на картинке диапазон. Application.WorksheetFunction.sum(rngX) конечно же выдаёт 4, а нужно 1.
Я не волшебник, я только учусь.
 
танцы с бубном..  :)  не уверен, что 100% правильно..)
Код
Sub tst()
Dim rng1 As Range
Dim rng2 As Range, smm As Long
Dim rng3 As Range, i As Long, adr As String, adrf As String
Dim rng4 As Range, rn(1 To 4), sm As Long
Dim rngX As Range
Set rng1 = Range("$F$9:$H$12"): rn(1) = rng1.Address
Set rng2 = Range("$G$5:$K$16"): rn(2) = rng2.Address
Set rng3 = Range("$G$10:$O$31"): rn(3) = rng3.Address
Set rng4 = Range("$G$1:$W$10"): rn(4) = rng4.Address
Set rngX = Union(rng1, rng2, rng3, rng4)
rngX.Select
For i = 1 To 3
    adr = Intersect(Range(rn(i)), Range(rn(i + 1))).Address
    If Len(adrf) = 0 Then adrf = adr Else adrf = adrf & "," & adr
    sm = sm + Application.WorksheetFunction.Sum(Range(adr))
Next
smm = Application.WorksheetFunction.Sum(rngX)
[d6].Value = smm - sm
Range("D7").FormulaLocal = "=sum(" & rngX.Address & ")-sum(" & adrf & ")"
End Sub
 
тут наткнулся на такое, что несколько удивило, не знал о такой форме записи

=SUM($F$9:$H$12 $G$5:$K$16 $G$10:$O$31 $G$1:$W$10)

Изменено: БМВ - 16.05.2018 13:08:00
По вопросам из тем форума, личку не читаю.
 
Пробел - операция пересечения диапазонов.
Изменено: sokol92 - 16.05.2018 13:38:11 (Обман зрения)
Владимир
 
sokol92, : 'это диапазон от и до
SUM(A1:A5:C1:C5:A2:C2) =SUM(A1:C5:A2:C2) =SUM(A1:C5) и это уже сработает не корректно. если будет в B4 значение.

другое дело, что это можно попытаться использовать
Изменено: БМВ - 16.05.2018 13:37:15
По вопросам из тем форума, личку не читаю.
 
Михаил, спасибо, уже понял.
Владимир
 
yozhik, Ваше решение корректно суммирует только ячейки "G10:H10", в которых пересекаются все диапазоны, если проставить значения в других ячейках - начинается дублирование при суммировании.

БМВ, спасибо. Очень интересная формула. может пригодится.

Сорри, что долго не отвечал. Пытался написать программу с использованием ваших решений. Из потенциально полезного - научился определять область пересечения диапазонов, но это пока ничем не помогает.

Вопрос ещё не закрыт.
Изменено: Wiss - 16.05.2018 13:47:29
Я не волшебник, я только учусь.
 
Цитата
Wiss написал:
Единственный косяк
это не косяк,  а ограничение для конкретного случая :-(. Возможно как то можно обернуть это в код, чтоб  оно считало все за нас, ведь по идее надо просуммировать объединенный диапазон (пусть даже пересечения там учтутся несколько раз) и вычитать из этой суммы полученные суммы пересечений столько раз сколько пересечений областей (парами)
Изменено: БМВ - 16.05.2018 13:50:08
По вопросам из тем форума, личку не читаю.
 
Михаил, для суммы - хорошая идея. Но "нормализовать" диапазон не получится.
Владимир
 
для конкретного примера не корректно, но просто для затравки , может идею разовьет кто.
Код
Sub test2()
Set a = Intersect(Selection, Selection)
S = Application.WorksheetFunction.Sum(a)
For i = 1 To a.Areas.Count
For j = i + 1 To a.Areas.Count
If Not Intersect(a.Areas(i), a.Areas(j)) Is Nothing Then _
 S = S - Application.Evaluate("=SUM(" & a.Areas(i).Address(, , Application.ReferenceStyle, True) & " " & a.Areas(j).Address(, , Application.ReferenceStyle, True) & ")")
Next
Next
End Sub
По вопросам из тем форума, личку не читаю.
 
рабочее решение
Код
Function SumByRange(ParamArray params() As Variant) As Variant
    Dim Rng As Range, iCell As Range, isect As Range
    Dim k As Integer, i As Integer
    
    k = UBound(params(), 1)
    If k >= 0 Then
        Set Rng = params(0)
        If k > 0 Then
            For i = 1 To k
                For Each iCell In params(i).Cells
                    Set isect = Application.Intersect(Rng, iCell)
                    If isect Is Nothing Then Set Rng = Union(Rng, iCell)
                Next iCell
            Next i
        End If
        SumByRange = 0
        For Each iCell In Rng.Cells
            If iCell Then  ' здесь надо сделать проверку на некорректные данные, но потом...
                SumByRange = SumByRange + iCell.Value
            End If
        Next iCell
    Else
        SumByRange = Null
    End If
End Function
Изменено: DenSyo - 16.05.2018 15:32:56
 
DenSyo,  А как это на больших диапазонах отработает?

           For i = 1 To k
               For Each iCell In params(i).Cells
+
           For Each iCell In Rng.Cell


На мой взгляд топит идею некими тормозами.
По вопросам из тем форума, личку не читаю.
 
пока не придумал как обозначить, что ячейка уже считалась. ввод массива флагов не вариант, какое-то действие с ячейкой не отражающееся на пересчете и отрисовке, но идей пока нет... по крайней мере то что есть работает.
Изменено: DenSyo - 16.05.2018 15:39:26
 
DenSyo, всё. Отлично работает, но в моём примере выдаёт 3, а не 1 (((
Я не волшебник, я только учусь.
 
на вашем примере все писал, работает и выдает 1) в любую ячейку вне считаемого диапазона вставьте =sumbyrange($F$9:$H$12;$G$5:$K$16;$G$10:$O$31;$G$1:$W$10)
Изменено: DenSyo - 16.05.2018 15:46:39
 
DenSyo, виноват. Я просто Selection впихивал и на нём выдавалось 3.
Я не волшебник, я только учусь.
 
Я сделаль!!! :D  :D  :D

Я сделал нормализацию несвязанных диапазонов  8) Ну как "сделал". Как всегда, есть нюансы. Надеюсь кто-нить додумает...

Какие косяки я знаю:

1. Функция myDiff - костыль с созданием копии листа родился из-за того, что некорректно работает заимствованная функция Difference. Там 2 строчки сейчас закоменчены. Они должны заполнять диапазон нулями, а потом возвращать значения, но в моём случае из-за кучи пустых ячеек они работают некорректно.

2. Там же в Difference, если у меня в одном из диапазонов выделен весь лист - выдаёт ошибку, что недостаточно системных ресурсов.

3. Если сделать дико сложный диапазон, то в myDiff возникает ошибка из-за слишком длинного адреса диапазона.


P.S. Мне вообще решение из Difference не очень нравится, но единственный из найденных мною альтернативных вариантов - перебирать каждую ячейку.
Изменено: Wiss - 16.05.2018 17:34:43
Я не волшебник, я только учусь.
 
Можно попробовать с моей аналогичной функцией (вместо difference).
Изменено: sokol92 - 16.05.2018 17:49:55
Владимир
 
Wiss, c доп. листом все элементарно, я не стал писать код создания листа и удаления, но это элементарщина.
Код
Set a = Intersect(Selection, Selection)
 Sheet1.Range(a.Address) = 1
 Set Rng = Range(Sheet1.Cells.SpecialCells(xlCellTypeConstants).Address)
По вопросам из тем форума, личку не читаю.
 
Михаил, Excel способен удивлять. Попробуйте на  Range("A1:A8192,A2:B2" )
Владимир
 
БМВ, или я Вас не понял, или Вы меня:) Функция Difference работает, но по задумке автора она должна:
1.Запоминать значения с рабочего диапазона
2 Очистить диапазон, заполнить его там, где надо.
3. Вернуть все значения обратно.

С возвращением значений, почему-то проблемы, вероятно из-за того что они некорректно запоминаются (те самые 2 закоменченных строчки). Поэтому пришлось копировать лист в новую книгу и определять диапазон в ней, но это как-то не очень...
Я не волшебник, я только учусь.
 
sokol92,

?selection.address
$A$1:$A$8192,$A$2:$B$2
? RNG.address
$B$2,$A$1:$A$8192
По вопросам из тем форума, личку не читаю.
 
Михаил, Вы правы. Это сообщение я написал, не проверив. :cry:  
Владимир
 
Похоже, что готово.  Или что-то я не учёл? Ну, кроме необходимости сокращения количества Areas в результате...
Код
Function normaliseRange(ByVal rngX As Range) As Range
'Преобразует несвязвнный диапазон так, чтобы в нем не было пересечений между Areas
    Dim rngDiv As Range
    Dim rngI As Range
    Dim rngI2 As Range
    Dim sAddress
    
    If rngX.Areas.Count = 1 Then
        Set normaliseRange = rngX
        Exit Function
    End If
    
    Set rngI = getIntersectionsInside(rngX)
    Set rngDiv = RngMinusRng(rngX, rngI)
       
    Do While rngI.Areas.Count > 1
        Set rngI2 = rngI
        Set rngI = getIntersectionsInside(rngI2)
        sAddress = RngMinusRng(rngI2, rngI).Address & ", " & rngDiv.Address
        If Len(sAddress) < 256 Then
            Set rngDiv = Range(sAddress)
        Else
            Set rngDiv = Nothing
            Exit Function
        End If
    Loop
    
    Set normaliseRange = Range(rngI.Address & ", " & rngDiv.Address)
End Function


Private Function getIntersectionsInside(ByVal rngX As Range) As Range
'Возвращает часть несвязанного диапазона, в котором есть пересечения между Areas
    Dim rngI As Range
    Dim i As Long
    Dim j As Long
    
    If rngX.Areas.Count = 1 Then
        Set getIntersectionsInside = rngX
        Exit Function
    End If
    
    For i = 1 To rngX.Areas.Count - 1
        For j = i + 1 To rngX.Areas.Count
            If Not Intersect(rngX.Areas(i), rngX.Areas(j)) Is Nothing Then
                If Not rngI Is Nothing Then
                    Set rngI = Union(rngI, Intersect(rngX.Areas(i), rngX.Areas(j)))
                Else
                    Set rngI = Intersect(rngX.Areas(i), rngX.Areas(j))
                End If
            End If
        Next j
    Next i
    
    Set getIntersectionsInside = Union(rngI, rngI)

End Function

Private Function RngMinusRng(ByVal rng1 As Range, ByVal rng2 As Range) As Range
'Returns Rng1 Minus Rng2
'by sokol92
'from https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=102628&a...
    Dim r As Range, ra As Range, r2 As Range
    Dim nrows As Long, ncols As Long, i As Long, j As Long
 
    With rng1.Parent
        nrows = .Rows.Count
        ncols = .Columns.Count
 
        Set RngMinusRng = rng1
        Set r = Intersect(rng1, rng2)
        If r Is Nothing Then                          ' диапазоны не пересекаются
            Exit Function
        End If
 
        For Each ra In r.Areas
            Set r2 = Nothing
            i = ra.Row + ra.Rows.Count
            j = ra.Column + ra.Columns.Count
            If ra.Column > 1 Then Set r2 = Union2(r2, .Range(.Cells(1, 1), .Cells(nrows, ra.Column - 1)))
            If ra.Row > 1 Then Set r2 = Union2(r2, .Range(.Cells(1, ra.Column), .Cells(ra.Row - 1, ncols)))
            If j <= ncols Then Set r2 = Union2(r2, .Range(.Cells(ra.Row, j), .Cells(i - 1, ncols)))
            If i <= nrows Then Set r2 = Union2(r2, .Range(.Cells(i, ra.Column), .Cells(nrows, ncols)))
 
            Set RngMinusRng = Intersect(RngMinusRng, r2)
        Next ra
 
    End With
End Function
 
Private Function Union2(r1 As Range, r2 As Range) As Range
'by sokol92
'from https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=102628&a...
    If r1 Is Nothing Then
        Set Union2 = r2
    Else
        Set Union2 = Union(r1, r2)
    End If
End Function
sokol92, позаимствовал Ваш код. Он классный и быстрый, но пока что не удалось в нём разобраться:-)
Я не волшебник, я только учусь.
 
Wiss, замечательно, нужно потестировать. Если позволите, еще советы:
  • постарайтесь не использовать свойство address - оно имеет известные ограничения
  • не обязательно возвращать нормализованный диапазон. Можно вернуть массив адресов непересекающихся прямоугольных областей или строку с адресами через запятую (а вот здесь не будет практических ограничений). Этого вполне достаточно для суммирования ячеек (исходная постановка задачи) и аналогичных задач.
Успехов!

P.S. По поводу алгоритма: r2 - весь лист (огромный прямоугольник) минус текущая прямоугольная область - дополнение ra до полного множества. Разность множеств совпадает с пересечением первого и дополнения второго.
Изменено: sokol92 - 16.05.2018 20:14:05
Владимир
 
А я вот так :-), но есть ограничение, что области на одном листе.
Код
Function normaliseRangeBMV(ByVal rngX As Range) As Range
    Set SourceSheet = rngX.Parent
    Set a = Intersect(rngX, rngX)
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    Sheets.Add
    Set TMPSheet = ActiveSheet
    SourceSheet.Activate
    With TMPSheet
        For Each Area In a
            .Range(Area.Address) = 1
        Next
        For Each Area In .Cells.SpecialCells(xlCellTypeConstants)
            If normaliseRangeBMV Is Nothing Then
                Set normaliseRangeBMV = SourceSheet.Range(Area.Address)
            Else
                Set normaliseRangeBMV = Union(normaliseRangeBMV, SourceSheet.Range(Area.Address))
            End If
        Next
     .Delete
    End With
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Function
Изменено: БМВ - 16.05.2018 21:18:07 (Исправлено)
По вопросам из тем форума, личку не читаю.
 
Михаил, то что диапазоны на одном листе - это правильно (я не умею создавать диапазон из ячеек разных листов). Хуже со свойством Address - если диапазон состоит из многих областей, то свойство вернет только первые (через запятую). Опять же Range(adr) споткнется, если adr содержит достаточно много адресов (через запятую).
Это можно обойти, если выделить перед копированием диапазон, очистить после копирования (Sheet.Copy) на новом листе все ячейки и загнать константу в Selection (на новом же листе). В функции, как я только что посоветовал коллеге, можно вернуть строку из адресов непересекающихся областей (Areas). Правда, на защищенном листе и это не получится.
Off. Я уже боюсь что-либо писать - сегодня достаточно наошибался :)  
Изменено: sokol92 - 16.05.2018 20:37:49
Владимир
 
sokol92, Владимир, Ваще не знаю зачем полез, обещал не кодить, наверно аномальная для Питера жара последних нескольких дней повлияла :-)

Спасибо за замечание , забывать стал о 256 заветных в ограничении строки. Возможно исправил выше.  
По вопросам из тем форума, личку не читаю.
 
Михаил, предательская строка 13 в новом варианте. :)
Off. Сегодня, действительно, тяжелый день. Я пару часов назад очень красиво оформил Ваш пример из #19 (почему и осмелился дать совет в #27), все протестировал и закрыл книгу без сохранения.
Владимир
 
Смерть предателям!!! :-)  . Пропустил эту строку. Переписал.

Цитата
sokol92 написал:
осмелился
Владимир, это не смелость, это наставничество :-) Я то себя в VBA статистом считаю.
По вопросам из тем форума, личку не читаю.
Страницы: 1 2 След.
Наверх