我想在同一个表中选择所有具有相同SrlNbr值和不同类型的行。 我尝试了很多方法但没有奏效。 请帮忙。 示例我想列出 ID:1,2, 5,6 而不是 3,4 ...
提示:本站收集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
我不确定您需要做什么,但是在分析了代码之后,我猜测您想要下面的代码。 该过程将查找极点基点并将其数据复制到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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.