Найти и извлечь значения в столбце, которые находятся в радиусе 6 футов от значения того же столбца

Question

Хорошо, ребята, я новичок в VBA и впервые публикую здесь.Вот моя ситуация, у меня есть список координат x, y, z, которые представляют точки съемки.В списке каждому набору координат назначен код объекта;есть только два разных (200 = точки заземления) & (311 = базовые точки полюса).В основном мне нужно найти координаты основания полюса, а затем найти все точки заземления, которые находятся в радиусе 6 футов от основания полюса, а затем поместить их на новый лист, где я могу выполнять дальнейшие вычисления, например определять разницу вЗначения z между базовой точкой полюса и точками заземления.См. Снимок экрана ниже, чтобы узнать, как выглядят данные опроса после импорта в Excel.

Я написал одну часть кода, чтобы найти номер полюса и координаты, отыскивая код элемента полюса "311" и вставив его на новый лист, но я не могу понять, как писатькод для нахождения точек заземления в радиусе 6 футов от полюса.Я знаю, что могу использовать формулу расстояния "= sqrt ((a2-a1) ^ 2 + (b2-b1) ^ 2)", но не знаю, как ее кодировать.Любая помощь будет принята с благодарностью.

Вот первая часть моего кода:

Sub embed_slope()
'
'
Dim P As Integer
Dim px As Long
Dim py As Long
Dim pz As Long
Dim gx As Long
Dim gy As Long
Dim gz As Long
P = 311
    For Row1 = 2 To 50
        For Row = 2 To 50
            Cells(Row, 3).Select                'search for pole feature code
            If Selection.Value = "" Then Exit For
            If Selection.Value = "311" Then
                ActiveCell.Offset(0, 8).Select      'copy pole number
                Selection.Copy
                Sheets("Data").Select
                Cells(Row1, 1).Select
                ActiveSheet.Paste                   'paste pole number on data sheet
                Sheets("Survey Input").Select
                Application.CutCopyMode = False
                ActiveCell.Offset(0, -7).Select     'copy coorinates
                Range(ActiveCell, ActiveCell.Offset(0, 2)).Copy
                Sheets("Data").Select
                Cells(Row1, 2).Select
                ActiveSheet.Paste
                Sheets("Survey Input").Select
                Application.CutCopyMode = False
            End If
        Next Row
    Next Row1
End Sub

Answer 1

Я не уверен, что вам нужно делать, но после анализа вашего кода, я предполагаю, что вы хотите что-то вроде этого кода ниже.Процедура ищет базовые точки полюсов и копирует их данные на лист Data, а затем ищет все точки заземления, которые находятся на расстоянии 6 футов от каждой базовой точки полюсов, а также копирует их данные на лист Data.Я использовал функцию fnDistance для расчета расстояния между точками.

Sub prcEmbedSlope()

    Dim wbWorkbook As Workbook
    Dim intBaseRow, intGroundRow As Integer
    Dim intTargetRow As Integer
    Dim dblXBase, dblYBase As Double
    Dim dblXGround, dblYGround As Double
    Dim dblDistance As Double

    Set wbWorkbook = Application.ThisWorkbook
    intTargetRow = 1

    'First loop (looking for pole base points)
    For intBaseRow = 2 To 15
        If wbWorkbook.Worksheets("Survey Input").Cells(intBaseRow, 3).Value = 311 Then
            dblXBase = wbWorkbook.Worksheets("Survey Input").Cells(intBaseRow, 4).Value
            dblYBase = wbWorkbook.Worksheets("Survey Input").Cells(intBaseRow, 5).Value
            'Copy pole base points data to the 2nd sheet
            wbWorkbook.Worksheets("Data").Cells(intTargetRow, 1).Value = wbWorkbook.Worksheets("Survey Input").Cells(intBaseRow, 1).Value
            wbWorkbook.Worksheets("Data").Cells(intTargetRow, 3).Value = wbWorkbook.Worksheets("Survey Input").Cells(intBaseRow, 3).Value
            wbWorkbook.Worksheets("Data").Cells(intTargetRow, 4).Value = wbWorkbook.Worksheets("Survey Input").Cells(intBaseRow, 4).Value
            wbWorkbook.Worksheets("Data").Cells(intTargetRow, 5).Value = wbWorkbook.Worksheets("Survey Input").Cells(intBaseRow, 5).Value
            wbWorkbook.Worksheets("Data").Cells(intTargetRow, 6).Value = wbWorkbook.Worksheets("Survey Input").Cells(intBaseRow, 6).Value
            intTargetRow = intTargetRow + 1
            'Second loop (looking for ground points within 6 ft. distance)
            For intGroundRow = 2 To 15
                If wbWorkbook.Worksheets("Survey Input").Cells(intGroundRow, 3).Value = 200 Then
                    dblXGround = wbWorkbook.Worksheets("Survey Input").Cells(intGroundRow, 4).Value
                    dblYGround = wbWorkbook.Worksheets("Survey Input").Cells(intGroundRow, 5).Value
                    dblDistance = fnDistance(dblXGround, dblYGround, dblXBase, dblYBase)
                    If dblDistance < 6 Then
                        'Copy ground points data to the 2nd sheet
                        wbWorkbook.Worksheets("Data").Cells(intTargetRow, 1).Value = wbWorkbook.Worksheets("Survey Input").Cells(intGroundRow, 1).Value
                        wbWorkbook.Worksheets("Data").Cells(intTargetRow, 3).Value = wbWorkbook.Worksheets("Survey Input").Cells(intGroundRow, 3).Value
                        wbWorkbook.Worksheets("Data").Cells(intTargetRow, 4).Value = wbWorkbook.Worksheets("Survey Input").Cells(intGroundRow, 4).Value
                        wbWorkbook.Worksheets("Data").Cells(intTargetRow, 5).Value = wbWorkbook.Worksheets("Survey Input").Cells(intGroundRow, 5).Value
                        wbWorkbook.Worksheets("Data").Cells(intTargetRow, 6).Value = wbWorkbook.Worksheets("Survey Input").Cells(intGroundRow, 6).Value
                        intTargetRow = intTargetRow + 1
                    End If
                End If
            Next intGroundRow
        End If
    Next intBaseRow

End Sub

Function fnDistance(ByVal dblXG As Double, ByVal dblYG As Double, _
                    ByVal dblXB As Double, ByVal dblYB As Double) As Double

fnDistance = Sqr((dblXG - dblXB) ^ 2 + (dblYG - dblYB) ^ 2)

End Function