Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Заполнение усредненными числами - области внутри треугольника
 
#1
18.11.2023 01:47:18
Добрый день. Помогите выполнить алгоритм в экселе с помощью VBA.

Сперва на листе экселя есть только три зеленые точки треугольника - в виде числовых величин (это исходные данные).
Нужно заполнить область внутри этого треугольника - усредненными значениями.
1) Определяются средние арифметические - в серединах сторон треугольника (желтые ячейки)
2) Затем от этих желтых точек проводятся линии к другим известным точкам и определяются усредненные значения уже там (оранжевые ячейки).
3) Аналогичным образом проводимых линий становится все больше и определяются все усредненные значения внутри внутри области треугольника.

Алгоритм примерно такой:
Код
Sub TEST()
    Dim RngA As Range, RngB As Range, RngC As Range
    Dim Ax#, Ay#, Bx#, By#, Cx#, Cy#
    
    Sheets.Add
    Cells.RowHeight = 12.75
    Cells.ColumnWidth = 2.29
    
    Set RngA = Cells(13, 17)
    Set RngB = Cells(10, 32)
    Set RngC = Cells(21, 29)
    RngA.Interior.Color = vbGreen: RngA.Value = 12
    RngB.Interior.Color = vbGreen: RngB.Value = 35
    RngC.Interior.Color = vbGreen: RngC.Value = -8
    
    Ax = (RngA.Left + RngA.Offset(0, 1).Left) / 2
    Ay = (RngA.Top + RngA.Offset(1, 0).Top) / 2
    Bx = (RngB.Left + RngB.Offset(0, 1).Left) / 2
    By = (RngB.Top + RngB.Offset(1, 0).Top) / 2
    Cx = (RngC.Left + RngC.Offset(0, 1).Left) / 2
    Cy = (RngC.Top + RngC.Offset(1, 0).Top) / 2
      
    With ActiveSheet.Shapes
        .AddConnector(msoConnectorStraight, Ax, Ay, Bx, By).Select
        .AddConnector(msoConnectorStraight, Bx, By, Cx, Cy).Select
        .AddConnector(msoConnectorStraight, Cx, Cy, Ax, Ay).Select
    End With
     
    Call CentrOtrezka(Ax, Ay, Bx, By, RngA.Value, RngB.Value)
    Call CentrOtrezka(Bx, By, Cx, Cy, RngB.Value, RngC.Value)
    Call CentrOtrezka(Cx, Cy, Ax, Ay, RngC.Value, RngA.Value)
    
End Sub
 
Sub CentrOtrezka(x1#, y1#, x2#, y2#, v1&, v2&)
    Dim x#, y#
    x = (x1 + x2) / 2
    y = (y1 + y2) / 2
 
    With ActiveSheet.Shapes.AddLine(x, y, x, y)
        .TopLeftCell.Select
        .Delete
    End With
    Selection.Interior.Color = vbYellow
    Selection.Value = CLng((v1 + v2) / 2)
End Sub
 
 
 
#2
18.11.2023 23:08:07
Помогите мне, пожалуйста решить эту задачу.
Если кто разбирается в программировании.
 
 
 
#3
18.11.2023 23:56:00
Цитата
Dalm написал:
Если кто разбирается в программировании.
да от куда тут такие?

Вы в результате что хотите получить? Вроде исходя из
Цитата
Dalm написал:
аналогичным образом проводимых линий становится все больше
вы получите бесконечно е количество значений. На плоскости будет бесконечное количество чисел, которые в результате не будут видны из-за наложения.
По вопросам из тем форума, личку не читаю.
 
 
 
#4
19.11.2023 00:07:24
Цитата
БМВ написал:
вы получите бесконечно е количество значений.
Отчего же ?
Ведь рано или поздно ячейки внутри треугольника заполнятся числами.
Тогда и нужно остановить алгоритм.
Цитата
БМВ написал:
На плоскости будет бесконечное количество чисел, которые в результате не будут видны из-за наложения.
Я наверное неправильно объяснил.
Нужно не весь лист заполнить числами, а только область внутри треугольника.
Наложения там никакого не будет, потому что если в рассматриваемой ячейке уже есть какое-то число - то макрос пропускает ее и идет дальше.
 
 
 
#5
19.11.2023 00:32:25
каждая итерация делит отрезки добавляя три точки  и это три новых отрезка, которые делятся пополам и снова дают три отрезка. и так далее. Все они внутри треугольника, но устремятся в его центр и это при условии что соединяем только новые точки. А если соединять все известные точки , то геометрическая прогрессия захлестнет.
По вопросам из тем форума, личку не читаю.
 
 
 
#6
19.11.2023 01:34:13
Тогда вот так:
Пусть к серединам проводятся отрезки только один раз - для получения трех крайних точек, лежащих на гранях треугольника.
Дальнейшие линии из точек отводятся не к серединам отрезков, а ко всем другим точкам.

Так линии распределятся по всему треугольнику ( и не устремятся в его центр)
 
 
 
#7
19.11.2023 10:47:21
Цитата
Dalm написал:
Так линии распределятся по всему треугольнику ( и не устремятся в его центр)
да в центр более не стремимся, но в бесконечность уходим.
Если одно из условий - дискретная сетка и аппроксимированный по ней треугольник, то могу предположить что каждая ячейка заполненная один раз более не трогается, тогда допускаю что "стоп игра" в зависимости от дискрета наступит быстро или очень быстро.
По вопросам из тем форума, личку не читаю.
 
 
 
#8
19.11.2023 11:47:19
БМВ, да, если ячейка заполненная один раз, то ее больше не трогают.
 
 
 
#9
19.11.2023 12:29:24
ну так и надо было написать , что из ячеек составлен произвольный треугольник. Я б в примере его показал, какие ячейки к нему относятся. Очень важный аспект это какую ячейку задействуем при расчете и занесении результата, так как линия может едва касаться ячейки.

Ну в любом случае, ждите заинтересованных макрушников.
По вопросам из тем форума, личку не читаю.
 
 
 
#10
19.11.2023 17:37:41
"Тупо в лоб" с помощью словаря. Возможно если применить другое округление а не (c3& = (c1& + c2&) \ 2) то результат будет несколько иным
Код
Sub Пример()
    With ActiveSheet
        TurboTestForDalm .Cells(10, "S"), .Cells(13, "D"), .Cells(21, "P")
    End With
End Sub

Sub TurboTestForDalm(cell1 As Range, cell2 As Range, cell3 As Range)
    Dim DctClls As New Dictionary, cell As Range, sh As Worksheet
    Dim r1&, r2&, c1&, c2&, r3&, c3&, v1&, v2&, v3&, addr, addr2, wrkFlg As Boolean
    
    Set sh = cell1.Worksheet
    With ActiveSheet
        DctClls.Add cell1.Address, cell1
        DctClls.Add cell2.Address, cell2
        DctClls.Add cell3.Address, cell3
    End With
    
    Do
        wrkFlg = False
        For Each addr In DctClls
            For Each addr2 In DctClls
                If addr <> addr2 Then
                    c1 = DctClls(addr).Column
                    c2 = DctClls(addr2).Column
                    r1 = DctClls(addr).Row
                    r2 = DctClls(addr2).Row
                    v1 = DctClls(addr).Value
                    v2 = DctClls(addr2).Value
                    c3 = (c1 + c2) \ 2
                    r3 = (r1 + r2) \ 2
                    v3 = (v1 + v2) \ 2
                    DoEvents
                    Set cell = sh.Cells(r3, c3)
                    If Not DctClls.Exists(cell.Address) Then
                        DctClls.Add cell.Address, cell
                        cell.Value = v3
                        If Not wrkFlg Then wrkFlg = True
                    End If
                End If
                
            Next
        Next
    Loop While wrkFlg
    
End Sub
Изменено: testuser - 19.11.2023 17:49:13
 
 
 
#11
20.11.2023 00:52:39
testuser,  Спасибо. Но у вас не треугольная область, а какая-то многоугольная получается.
То что выходит за пределы треугольной области - считать не надо.
Но если уже подсчитано - то нужно хотя бы удалить лишнее макросом.
 
 
 
#12
20.11.2023 12:20:09
Dalm, в данном случае уровень моего энтузиазма становится чуть менее чем дотаточным, в виду усложнившихся условий и отсутствия хоть отдаленно-примерного понимания назначения данного вида решения
 
 
 
#13
20.11.2023 13:07:40
Цитата
testuser написал:
назначения данного вида решения

Назначение - это интерполяция по площади.
Насчет треугольника - я в самом начале темы написал, что это треугольник.
 
 
 
#14
20.11.2023 13:39:56
Цитата
Dalm написал:
интерполяция по площади
Вот это лучше было бы указать в заголовке
 
 
 
#15
20.11.2023 14:30:04
testuser, так вот же заголовок:
"Заполнение усредненными числами - области внутри треугольника"

Усредненными числами - это и есть интерполяция.
 
 
 
#16
20.11.2023 16:06:14
Цитата
Dalm написал:
так вот же заголовок:
Если бы вы указали слово "интерполляция" то люди которые в этом понимают, а такие точно сдесь есть" возмжно зашли бы в эту тему и могли бы чего-то подсказать, в то же время, люди не понимающие в интерполляции (такие как я) могли бы просто не заходить.. И общение могло бы получиться продуктивней..
 
 
 
#17
20.11.2023 18:45:07
Dalm, Какая конечная задача данных этой интерполяции ?
Изменено: doober - 20.11.2023 21:51:43
 
 
 
#18
20.11.2023 19:45:24
Цитата
doober написал:
Какая конечная задача данных этой интерполяции
Если это вопрос, то не хватает "?" . Если утверждение, то опечатка

Какая конченая задача данных этой интерполяции.
По вопросам из тем форума, личку не читаю.
 
 
 
#19
20.11.2023 21:52:26
Изменил, хотя второй вариант понравился
 
 
 
#20
21.11.2023 00:51:45
Как же решить - эту непростую задачу ?
 
 
 
#21
21.11.2023 10:37:24
Цитата
doober написал:
Какая конечная задача данных этой интерполяции ?
Вы не ответили на этот вопрос.
 
 
 
#22
21.11.2023 12:50:46
doober,  конечная задача - определить числовое значение в произвольной области этого треугольника.
Разве не для этого интерполяцию проводят ?
 
 
 
#23
21.11.2023 14:50:53
Интерполяция треугольника используется для получения координат точки в области треугольника..
Вбейте в поиск в яндексе  Интерполяция треугольника , есть некоторые решения.
 
 
 
#24
21.11.2023 14:58:23
Подскажите, как вот в этом макросе - удалить лишние цифры, выходящие за пределы треугольной области ?
Макрос уже все подсчитал, но лишние ячейки заполнил.
 
 
 
#25
21.11.2023 17:31:45
Только потому, что интерено было проверить метод "бариоцентрических координат", он действительн работает! А так то в целом не в особом почете такие полу-абстрактные задачи без хотябы минимального понимания практической подоплеки. Если убрать точку пере .Round будет "банковское" округление иначе - "математическое"
Код
Sub TriangleInterpol(cell1 As Range, cell2 As Range, cell3 As Range)
    Dim DctClls As New Dictionary, cell As Range, sh As Worksheet
    Dim r1!, r2!, c1!, c2!, r3!, c3!, v1!, v2!, v3!, addr, addr2, wrkFlg As Boolean
    Dim w1!, w2!, w3!, r11!, r22!, r33!, c11!, c22!, c33!
    
    Set sh = cell1.Worksheet
    DctClls.Add cell1.Address, cell1
    DctClls.Add cell2.Address, cell2
    DctClls.Add cell3.Address, cell3
    
    r11 = cell1.Row
    r22 = cell2.Row
    r33 = cell3.Row
    c11 = cell1.Column
    c22 = cell2.Column
    c33 = cell3.Column
    
    Do
        wrkFlg = False
        For Each addr In DctClls
            For Each addr2 In DctClls
                If addr <> addr2 Then
                    c1 = DctClls(addr).Column
                    c2 = DctClls(addr2).Column
                    r1 = DctClls(addr).Row
                    r2 = DctClls(addr2).Row
                    v1 = DctClls(addr).Value
                    v2 = DctClls(addr2).Value
                    Select Case 1
                    Case Is < Abs(c1 - c2), Is < Abs(r1 - r2)
                        With WorksheetFunction
                          c3 = .Round((c1 + c2) / 2, 0)
                          r3 = .Round((r1 + r2) / 2, 0)
                          
                          DoEvents
                          Set cell = sh.Cells(r3, c3)
                          If Not DctClls.Exists(cell.Address) Then
                              'Барицентрические координаты
                              w1 = ((r22 - r33) * (c3 - c33) + (c33 - c22) * (r3 - r33)) / ((r22 - r33) * (c11 - c33) + (c33 - c22) * (r11 - r33))
                              w2 = ((r33 - r11) * (c3 - c33) + (c11 - c33) * (r3 - r33)) / ((r22 - r33) * (c11 - c33) + (c33 - c22) * (r11 - r33))
                              w3 = 1 - w1 - w2
  '                            cell.Select
                              If w1 * w2 * w3 >= 0 Then
                                  DctClls.Add cell.Address, cell
                                  v3 = .Round((v1 + v2) \ 2, 0)
                                  DoEvents
                                  cell.Value = v3
                                  If Not wrkFlg Then wrkFlg = True
                              End If
                          End If
                        End With
                    End Select
                End If
            Next
        Next
    Loop While wrkFlg
    
End Sub
Изменено: testuser - 21.11.2023 18:33:14
 
 
 
#26
21.11.2023 21:56:42
testuser, спасибо
 
 
 
Страницы: 1
Наверх