# 在同一列的值的6'半径内查找和提取列中的值Find and extract values in a column that are in a 6' radius of a value of the same column

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 个回复1

### #1楼 票数：0

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

2回复

2回复

1回复

1回复

1回复

1回复

2回复

2回复