在同一列的值的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