Как макросом - провести линии меду центрами ячеек, с условием, что если - либо обе абсциссы линии, либо обе ее ординаты одинаковы - только тогда линия рисуется ?
Добрый вечер. Помогите с решением.
Как макросом - провести линии меду центрами ячеек, с условием, что если - либо обе абсциссы линии, либо обе ее ординаты одинаковы - только тогда линия рисуется ?SergVrn
Ну - вообще ВСЕ - не выходит. Я не знаю как эту задачу решить.
Разве что есть примерная идея реализации: 1)Макрос соединяет все без исключения ячейки - линиями. 2)Определяет линии у которых - либо обе абсциссы равны, либо обе ординаты равны - и удаляет их.
Ну - вообще ВСЕ - не выходит. Я не знаю как эту задачу решить.
Разве что есть примерная идея реализации: 1)Макрос соединяет все без исключения ячейки - линиями. 2)Определяет линии у которых - либо обе абсциссы равны, либо обе ординаты равны - и удаляет их.
SergVrn Если ничего не выходит, значит что-то сделано. Можно на это взглянуть? 1. чтоб определить, надо или е надо соединять пару, надо сравнить индекс столбца и строки ячеек. При равенстве одного из двух, нужна линия. 2. Рисуем линию из координат Cells.top+Cells.hight/2 и Cells.left+cells.width/2 до точки середины второй ячейки.
SergVrn Если ничего не выходит, значит что-то сделано. Можно на это взглянуть? 1. чтоб определить, надо или е надо соединять пару, надо сравнить индекс столбца и строки ячеек. При равенстве одного из двух, нужна линия. 2. Рисуем линию из координат Cells.top+Cells.hight/2 и Cells.left+cells.width/2 до точки середины второй ячейки.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Сообщение отредактировал bmv98rus - Воскресенье, 17.12.2017, 23:18
doober, а геометрия не говорит, по отношению к чему этот угол считать? :-) Или вы предлакаете сперва высчитать угловой коэффицент прямой проходящей через две точки и после этого принять решение? в таком случае как раз равенство X1,X2 и Y1,Y2 даст 0 в разнице и зачем тогда все эти расчеты?
doober, а геометрия не говорит, по отношению к чему этот угол считать? :-) Или вы предлакаете сперва высчитать угловой коэффицент прямой проходящей через две точки и после этого принять решение? в таком случае как раз равенство X1,X2 и Y1,Y2 даст 0 в разнице и зачем тогда все эти расчеты?bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Если ничего не выходит, значит что-то сделано. Можно на это взглянуть
Ну продвинулся я - не ахти как далеко. Сейчас, в настоящее время имеющийся макрос - просто соединяет все без исключения "ячейки с единицами" - линиями. Получается такая - хаотическая паутина.
А вот если бы как-то наклонные линии (после работы данного макроса) - автоматически удалить - вот этого я сделать не могу.
Если ничего не выходит, значит что-то сделано. Можно на это взглянуть
Ну продвинулся я - не ахти как далеко. Сейчас, в настоящее время имеющийся макрос - просто соединяет все без исключения "ячейки с единицами" - линиями. Получается такая - хаотическая паутина.
А вот если бы как-то наклонные линии (после работы данного макроса) - автоматически удалить - вот этого я сделать не могу.SergVrn
SergVrn, как Вам и говорили, можно условие соответствующее, поставить:
[vba]
Код
Option Explicit Private Type t_Coor X As Double Y As Double End Type
Private Type t_XLine A As t_Coor B As t_Coor A2B As Double v As Boolean End Type
Function PinAB(P As t_Coor, L As t_XLine) As Boolean PinAB = (P.X - L.A.X) * (L.B.X - P.X) > 0 Or (P.Y - L.A.Y) * (L.B.Y - P.Y) > 0 End Function
Sub main() Dim L() As t_XLine Dim aP() As t_Coor Dim CP As Long Dim UL As Long Dim UC As Long, US As Long Dim P As t_Coor Dim rn As Range, i As Long, j As Long, ws As Worksheet Set ws = ActiveSheet Dim sh, ash() 'As Shapes For Each sh In ws.Shapes sh.Delete Next sh
For Each rn In ws.UsedRange If rn = 1 Then ReDim Preserve aP(CP) aP(CP).X = rn.Column aP(CP).Y = rn.Row For i = 0 To CP - 1 ReDim Preserve L(UL), ash(UL) With L(UL) .A = aP(i) .B = aP(CP) .A2B = A2B(.A, .B) .v = True '''''''''''''''''''''''''''''''''''''' If (rn.Left = Cells(.A.Y, .A.X).Left) Or (rn.Top = Cells(.A.Y, .A.X).Top) Then Set ash(UL) = ws.Shapes.AddLine(rn.Left, rn.Top, Cells(.A.Y, .A.X).Left, Cells(.A.Y, .A.X).Top) '.Select ash(UL).Select End If ''''''''''''''''''''''''''''''''''''' End With
UL = UL + 1 Next i CP = CP + 1 End If Next rn End Sub
'расстояние от точки до точки Private Function A2B(A As t_Coor, B As t_Coor) As Double A2B = Sqr((A.X - B.X) * (A.X - B.X) + (A.Y - B.Y) * (A.Y - B.Y)) End Function
[/vba]
Ну а если Вам принципиально создавать линию через центры ячеек, то стоит использовать : [vba]
SergVrn, как Вам и говорили, можно условие соответствующее, поставить:
[vba]
Код
Option Explicit Private Type t_Coor X As Double Y As Double End Type
Private Type t_XLine A As t_Coor B As t_Coor A2B As Double v As Boolean End Type
Function PinAB(P As t_Coor, L As t_XLine) As Boolean PinAB = (P.X - L.A.X) * (L.B.X - P.X) > 0 Or (P.Y - L.A.Y) * (L.B.Y - P.Y) > 0 End Function
Sub main() Dim L() As t_XLine Dim aP() As t_Coor Dim CP As Long Dim UL As Long Dim UC As Long, US As Long Dim P As t_Coor Dim rn As Range, i As Long, j As Long, ws As Worksheet Set ws = ActiveSheet Dim sh, ash() 'As Shapes For Each sh In ws.Shapes sh.Delete Next sh
For Each rn In ws.UsedRange If rn = 1 Then ReDim Preserve aP(CP) aP(CP).X = rn.Column aP(CP).Y = rn.Row For i = 0 To CP - 1 ReDim Preserve L(UL), ash(UL) With L(UL) .A = aP(i) .B = aP(CP) .A2B = A2B(.A, .B) .v = True '''''''''''''''''''''''''''''''''''''' If (rn.Left = Cells(.A.Y, .A.X).Left) Or (rn.Top = Cells(.A.Y, .A.X).Top) Then Set ash(UL) = ws.Shapes.AddLine(rn.Left, rn.Top, Cells(.A.Y, .A.X).Left, Cells(.A.Y, .A.X).Top) '.Select ash(UL).Select End If ''''''''''''''''''''''''''''''''''''' End With
UL = UL + 1 Next i CP = CP + 1 End If Next rn End Sub
'расстояние от точки до точки Private Function A2B(A As t_Coor, B As t_Coor) As Double A2B = Sqr((A.X - B.X) * (A.X - B.X) + (A.Y - B.Y) * (A.Y - B.Y)) End Function
[/vba]
Ну а если Вам принципиально создавать линию через центры ячеек, то стоит использовать : [vba]
Надо все правильно делать с заделом на будущее. Есть у меня класс геометрия. Производятся в нем любые расчеты . Надо найти точки пересечения окружности с прямой, вызвал функцию, передал параметры, получил результат. Надо вычислить площадь многоугольника, передал массив точек, на выходе площадь. И т.д.
Надо все правильно делать с заделом на будущее. Есть у меня класс геометрия. Производятся в нем любые расчеты . Надо найти точки пересечения окружности с прямой, вызвал функцию, передал параметры, получил результат. Надо вычислить площадь многоугольника, передал массив точек, на выходе площадь. И т.д.doober
ash(UL).Select End If '''''''''''''''''''''''''''''''''''''
[/vba] Но в целом, над макросом стоило бы ещё поработать, поскольку он создаёт линии, повторяющие геометрию предыдущих линий... или так и задумано?Roman777
Много чего не знаю!!!!
Сообщение отредактировал Roman777 - Воскресенье, 17.12.2017, 21:51
поскольку он создаёт линии, повторяющие геометрию предыдущих линий
Да действительно - некоторые линии перекрываются. А это как можно решить ?
Я просто не понимаю как сформулировать алгоритм для удаления перекрывающихся линий. У них ведь - либо абсциссы, либо ординаты - одинаковые, и по основному-то условию - они проходят.
поскольку он создаёт линии, повторяющие геометрию предыдущих линий
Да действительно - некоторые линии перекрываются. А это как можно решить ?
Я просто не понимаю как сформулировать алгоритм для удаления перекрывающихся линий. У них ведь - либо абсциссы, либо ординаты - одинаковые, и по основному-то условию - они проходят.SergVrn
SergVrn, 1. формируем массив ячеек с 1, тупка перебирая используемую область, а еще проще быстрее наверно не пустые взять, через SpecialCells 2. Без преебора не обойтись, но берем проверяем пары сравнивая 1я последующими и при выполнении условия сохраняем отдельно , ну елси геометрия, то длинну линии по вертикали и горизонтали отдельно. По окончанию рисуем эти две линии. 3. повторяем 2, но 2я сравнивается с оставшимися... и так далее. тем самым решится вопрос перекрывающих линий.
SergVrn, 1. формируем массив ячеек с 1, тупка перебирая используемую область, а еще проще быстрее наверно не пустые взять, через SpecialCells 2. Без преебора не обойтись, но берем проверяем пары сравнивая 1я последующими и при выполнении условия сохраняем отдельно , ну елси геометрия, то длинну линии по вертикали и горизонтали отдельно. По окончанию рисуем эти две линии. 3. повторяем 2, но 2я сравнивается с оставшимися... и так далее. тем самым решится вопрос перекрывающих линий.
bmv98rus, я не понял - так условие удаления одной из перекрывающейся линий - как должно выглядеть ?
То есть должен быть какой-то итоговый массив линий (после работы основного макроса).
И начинает действовать что-то типа условия : проверяется - для каждой линии - либо одна из ее абсцисс - находится между абсциссами одной из прочих линий массива. Либо одна из ординат этой линии - находится между ординатами одной из прочих линий массива. Те нарисованные линии, которые подходят под это условие - удаляются с листа.
Или вы написали более простое решение ? (Я просто не понял, что у вас в трех пунктах написано.)
bmv98rus, я не понял - так условие удаления одной из перекрывающейся линий - как должно выглядеть ?
То есть должен быть какой-то итоговый массив линий (после работы основного макроса).
И начинает действовать что-то типа условия : проверяется - для каждой линии - либо одна из ее абсцисс - находится между абсциссами одной из прочих линий массива. Либо одна из ординат этой линии - находится между ординатами одной из прочих линий массива. Те нарисованные линии, которые подходят под это условие - удаляются с листа.
Или вы написали более простое решение ? (Я просто не понял, что у вас в трех пунктах написано.)SergVrn
SergVrn, По попробую по другому. В экселе у вас ограничено пространство левым верхним углом и с него начнется перебор используемой областью, и это можно использовать. Берем первую точку X1Y1и вторую X2Y2, проверяем на условие совпадения X1=X2 Или Y1=Y2 , Каким методом - сравнением в каком ряду или столбце ячейки или именно коррдинат ,Вам решать. При совпадении запоминаем две различных точки , с равными иксами и игриками, одна для вертикального и одна для горизонтального отрезка. Bерем следующую точку X3Y3 и также перебором X1=X3 Или Y1=Y3 ,при совпадении сравниваем растония Abs(X3-x1)< Abs(X2-X1) Если да, на место X2Y2 запоминам X3Y3 в соответвующей горизонтали или вертикали. таким образом доходите до конца и по завершении у вас не более трех точек X1Y1 и е1 возможные пары, с минимальным растояниями между ними. Можно рисовать отрезки от X1Y1 lдо полученных точек (их может не быть, если X1Y1 "на отшибе". Теперь повторяем все это, но от точки X2Y2. В целом вопрос уже не связан с Excel. С ним связано только определение центра координат ячейки.
SergVrn, По попробую по другому. В экселе у вас ограничено пространство левым верхним углом и с него начнется перебор используемой областью, и это можно использовать. Берем первую точку X1Y1и вторую X2Y2, проверяем на условие совпадения X1=X2 Или Y1=Y2 , Каким методом - сравнением в каком ряду или столбце ячейки или именно коррдинат ,Вам решать. При совпадении запоминаем две различных точки , с равными иксами и игриками, одна для вертикального и одна для горизонтального отрезка. Bерем следующую точку X3Y3 и также перебором X1=X3 Или Y1=Y3 ,при совпадении сравниваем растония Abs(X3-x1)< Abs(X2-X1) Если да, на место X2Y2 запоминам X3Y3 в соответвующей горизонтали или вертикали. таким образом доходите до конца и по завершении у вас не более трех точек X1Y1 и е1 возможные пары, с минимальным растояниями между ними. Можно рисовать отрезки от X1Y1 lдо полученных точек (их может не быть, если X1Y1 "на отшибе". Теперь повторяем все это, но от точки X2Y2. В целом вопрос уже не связан с Excel. С ним связано только определение центра координат ячейки.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Сообщение отредактировал bmv98rus - Понедельник, 18.12.2017, 14:54