繁体   English   中英

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

Find and extract values in a column that are in a 6' radius of a value of the same column

提示:本站收集StackOverFlow近2千万问答,支持中英文搜索,鼠标放在语句上弹窗显示对应的参考中文或英文, 本站还提供   中文繁体   英文版本   中英对照 版本,有任何建议请联系yoyou2525@163.com。

好的,我是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

调查数据

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
3 在Spotfire中的同一列中提取两个值

我是spotfire的初学者。 我需要从下面显示的数据中创建一个计算列 第一列是学校列表,第二列是学生在考试中获得的等级列表,第三列是特定学生得到的分数/标记。 我需要创建一个计算列,以便对应于每个学校的每个第4级排名,我需要看到在同一所学校中Rank1和Rank4获得的分数差异。 ...

4 R:在同一列中查找匹配值的索引

今天这给我带来了很多麻烦,我确信有一个明显的解决方案,我没想到。 我有几千行的数据框。 有一列,该列中的每个值恰好出现两次。 我想找到每个匹配值的索引。 该列看起来像这样: 我想知道匹配出现的相应索引,所以它将返回如下内容: ...

5 查找与同一列中的多个值匹配的不同元素

可以说这是我正在谈论的桌子 我需要获取与fId列表中所有给定索引匹配的pId列表。 我的意思是-&gt; 认为fId的列表为: 那么结果应该是 因为只有pId 2才能匹配fId列表中的所有给定条目(分别为1和2)。 到目前为止,我找不到任何方法-非常感谢 ...

2016-04-18 14:29:54 1 16   mysql/ sql
7 在同一列中的某个值之后查找行

我的数据框中有一列包含由零中断的升序数字。 我想找到零之前的所有行并创建一个仅包含这些行的新数据表。 我需要什么: 4, 6 任何帮助将非常感激! 谢谢! ...

2021-07-08 09:10:45 4 42   r
9 在多个工作表的同一列中的查找值

在关于我的工作簿中的五页三(面包,花卉,食品杂货店)列B,我想找到这个字行Flyer B列有将在每个工作表中多行这个字Flyer列B当找到单词Flyer ,它将把整行粘贴到Sheet1中。 我将其放在一个选项卡上,但是希望使用相同的代码搜索所有三个选项卡(但不是全部五个...这是问题所在) ...

2015-06-02 21:20:42 4 577   excel/ vba
10 SQL Query在同一列中查找值的乘积

面试问题之前问过。 给定一个包含boxName和value列的表,找到每个框的音量。 值字段具有立方体的长度,bredth和高度。 我需要乘以所有树的尺寸。 如果需要计算总和,我可以使用groupby ,但此处需要产品 ...

暂无
暂无

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2022 STACKOOM.COM