Макрос VBA для простановки номеров в поворотных точках контура, для полигонов.

+ добавляет в четвертый столбец дистанции  между точками.

Пробегается по списку X и Y, в случае, если находит повторяющиеся координаты (замыкающие контур) ставит в первый столбец номер начала контура и начало следующего контура делает жирным шрифтом.

Принимает перечень со первой/второй строки, столбцы 2 и 3 с координатами XY и берет за начало первого контура.

* Дополнение от декабря 2024: Делает отдельную запись с номером контура для целей QGIS (точки в путь)

* Дополнение от марта 2025: Без разницы, с первой или второй строки начало координат, расстояние между точками округлено до 2 знаков после запятой.

 

Sub CounterPolygons()

    Dim Distance As Double

    Dim Count, tmpCount As Integer

    Dim PolyCount As Integer

    PolyCount = 1 'Counter of polygons

    Count = 1 'Main counter

    CellNum = 2

    tmpCount = Count

    If IsEmpty(Cells(1, 2)) Then CellNum = 2 Else CellNum = 1  'what first line number of XY?

    myX = Cells(CellNum, 2)

    myY = Cells(CellNum, 3)

        Do While Cells(CellNum, 2) > 0

            Cells(CellNum, 1) = Count

            CellNum = CellNum + 1

            ' distance calc

            X1 = Cells(CellNum - 1, 2)

            X2 = Cells(CellNum, 2)

            Y1 = Cells(CellNum, 3)

            Y2 = Cells(CellNum - 1, 3)

            Distance = ((X2 - X1) ^ 2) + ((Y2 - Y1) ^ 2)

            Cells(CellNum, 4) = Round(Sqr(Distance), 2)

            'end of distance calc

            Cells(CellNum, 5) = PolyCount

           

            If Cells(CellNum, 2) = myX And Cells(CellNum, 3) = myY Then

                PolyCount = PolyCount + 1

                Cells(CellNum, 1) = tmpCount

                'Bold

                Cells(CellNum + 1, 1).Font.Bold = True

                Cells(CellNum + 1, 2).Font.Bold = True

                Cells(CellNum + 1, 3).Font.Bold = True

                'end Bold

                myX = Cells(CellNum + 1, 2)

                myY = Cells(CellNum + 1, 3)

                Cells(CellNum + 1, 5) = PolyCount

                Count = Count + 1

                tmpCount = Count

                CellNum = CellNum + 1

            Else

                Count = Count + 1

            End If

        Loop

End Sub