В vba фактически происходит то же самое. Формула СУММ выделенных диапазонов выдаёт 4 из-за того, что все они пересекаются в ячейке G10.
Как можно это обойти? Как получить корректную сумму этого диапазона? Я пробовал загонять значения всех ячеек в массив, но это топорно+медленно при большом диапазоне.
В идеале - нужно преобразовать несвязанный диапазон в другой несвязанный диапазон, в котором не будет пересечений между Areas, но у меня нет идей как это сделать, причём быстро.
В примере файлик с кусочком кода, который формирует и выделяет показанный на картинке диапазон. Application.WorksheetFunction.sum(rngX) конечно же выдаёт 4, а нужно 1.
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
yozhik, Ваше решение корректно суммирует только ячейки "G10:H10", в которых пересекаются все диапазоны, если проставить значения в других ячейках - начинается дублирование при суммировании.
БМВ, спасибо. Очень интересная формула. может пригодится.
Сорри, что долго не отвечал. Пытался написать программу с использованием ваших решений. Из потенциально полезного - научился определять область пересечения диапазонов, но это пока ничем не помогает.
это не косяк, а ограничение для конкретного случая :-(. Возможно как то можно обернуть это в код, чтоб оно считало все за нас, ведь по идее надо просуммировать объединенный диапазон (пусть даже пересечения там учтутся несколько раз) и вычитать из этой суммы полученные суммы пересечений столько раз сколько пересечений областей (парами)
для конкретного примера не корректно, но просто для затравки , может идею разовьет кто.
Код
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
пока не придумал как обозначить, что ячейка уже считалась. ввод массива флагов не вариант, какое-то действие с ячейкой не отражающееся на пересчете и отрисовке, но идей пока нет... по крайней мере то что есть работает.
на вашем примере все писал, работает и выдает 1) в любую ячейку вне считаемого диапазона вставьте =sumbyrange($F$9:$H$12;$G$5:$K$16;$G$10:$O$31;$G$1:$W$10)
Я сделал нормализацию несвязанных диапазонов Ну как "сделал". Как всегда, есть нюансы. Надеюсь кто-нить додумает...
Какие косяки я знаю:
1. Функция myDiff - костыль с созданием копии листа родился из-за того, что некорректно работает заимствованная функция Difference. Там 2 строчки сейчас закоменчены. Они должны заполнять диапазон нулями, а потом возвращать значения, но в моём случае из-за кучи пустых ячеек они работают некорректно.
2. Там же в Difference, если у меня в одном из диапазонов выделен весь лист - выдаёт ошибку, что недостаточно системных ресурсов.
3. Если сделать дико сложный диапазон, то в myDiff возникает ошибка из-за слишком длинного адреса диапазона.
P.S. Мне вообще решение из Difference не очень нравится, но единственный из найденных мною альтернативных вариантов - перебирать каждую ячейку.
БМВ, или я Вас не понял, или Вы меня:) Функция Difference работает, но по задумке автора она должна: 1.Запоминать значения с рабочего диапазона 2 Очистить диапазон, заполнить его там, где надо. 3. Вернуть все значения обратно.
С возвращением значений, почему-то проблемы, вероятно из-за того что они некорректно запоминаются (те самые 2 закоменченных строчки). Поэтому пришлось копировать лист в новую книгу и определять диапазон в ней, но это как-то не очень...
Похоже, что готово. Или что-то я не учёл? Ну, кроме необходимости сокращения количества 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 до полного множества. Разность множеств совпадает с пересечением первого и дополнения второго.
А я вот так :-), но есть ограничение, что области на одном листе.
Код
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
Михаил, то что диапазоны на одном листе - это правильно (я не умею создавать диапазон из ячеек разных листов). Хуже со свойством Address - если диапазон состоит из многих областей, то свойство вернет только первые (через запятую). Опять же Range(adr) споткнется, если adr содержит достаточно много адресов (через запятую). Это можно обойти, если выделить перед копированием диапазон, очистить после копирования (Sheet.Copy) на новом листе все ячейки и загнать константу в Selection (на новом же листе). В функции, как я только что посоветовал коллеге, можно вернуть строку из адресов непересекающихся областей (Areas). Правда, на защищенном листе и это не получится. Off. Я уже боюсь что-либо писать - сегодня достаточно наошибался
Михаил, предательская строка 13 в новом варианте. Off. Сегодня, действительно, тяжелый день. Я пару часов назад очень красиво оформил Ваш пример из #19 (почему и осмелился дать совет в #27), все протестировал и закрыл книгу без сохранения.