在同一列的值的6'半径内查找和提取列中的值

Question

好的，我是VBA的新手，也是第一次来这里。 这是我的情况，我有一个代表调查点的x，y，z坐标列表。 在列表中，每组坐标都有一个分配的特征代码。 只有两个不同的（200 =地面点）和（311 =极点基点）。 我基本上需要找到极点座标，然后找到极点半径为6英尺的所有地面点，然后将其放在新的图纸上，在这里我可以进行进一步的计算，例如确定极点基点和地面点之间的z值。 导入以下表格后，请参阅以下屏幕截图，以获取调查数据的外观。

我编写了一部分代码，通过寻找极点特征代码“ 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