查找距离阈值下的点对及坐标提取
1. 需求分析
这个 VBA 程序的主要目标是：
- 从工作表中查找距离小于指定阈值的点对
- 记录这些点对的信息和距离
- 通过 VLOOKUP 函数提取点对的坐标信息
- 将结果格式化输出到新工作表
2. 程序流程图
3. 关键 VBA 技术点解析
3.1 性能优化技术
' 禁用屏幕刷新和自动计算以提升性能
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
3.2 数组操作
' 声明动态数组
Dim dataMatrix() As Variant
' 从工作表读取数据到数组
dataMatrix = wsSource.Range(...).Value
' 动态调整数组大小
ReDim Preserve results(1 To 4, 1 To itemCount)
3.3 工作表操作
' 错误处理和工作表创建
On Error Resume Next
Set wsResult = ThisWorkbook.Worksheets("04. Distance check")
If wsResult Is Nothing ThenSet wsResult = ThisWorkbook.Worksheets.AddwsResult.Name = "04. Distance check"
End If
On Error GoTo 0
3.4 Excel 公式应用
' 使用 VLOOKUP 函数获取坐标信息
.Range("E2").Formula = "=VLOOKUP($B2,'03.Obj Geom - Point Coordinates'!$A:$D,2,FALSE)"
4. 代码结构详解
4.1 变量声明部分
Dim wsSource As Worksheet, wsResult As Worksheet
Dim lastRow As Long, lastCol As Long
Dim dataMatrix() As Variant
Dim results() As Variant
- 使用
Dim声明变量 - 使用描述性变量名提高代码可读性
4.2 数据读取部分
lastRow = wsSource.Range("F" & wsSource.Rows.Count).End(xlUp).Row
lastCol = wsSource.Cells(3, wsSource.Columns.Count).End(xlToLeft).Column
dataMatrix = wsSource.Range(...).Value
- 使用
End(xlUp)和End(xlToLeft)定位数据范围 - 一次性读取数据到数组提高效率
4.3 数据处理部分
For i = 2 To arrRowCountFor j = 1 To arrColCountIf IsNumeric(dataMatrix(i, j)) ThenIf dataMatrix(i, j) < threshold And dataMatrix(i, j) <> 0 Then' 处理逻辑End IfEnd IfNext j
Next i
- 使用嵌套循环遍历数据
- 使用条件判断筛选有效数据
5. 实用技巧
5.1 使用计时器
startTime = Timer
' ... 代码执行 ...
executionTime = Format(Timer - startTime, "0.00")
5.2 数组动态扩展
ReDim Preserve results(1 To 4, 1 To itemCount)
5.3 单元格格式化
With .Range("A1:H1").Font.Bold = True.Interior.Color = RGB(200, 200, 200)
End With
Sub FindUnderDistanceValues()Dim wsSource As Worksheet, wsResult As WorksheetDim lastRow As Long, lastCol As LongDim i As Long, j As LongDim dataMatrix() As VariantDim point2Array() As VariantDim results() As VariantDim itemCount As LongDim threshold As DoubleDim startTime As DoubleDim p1 As String, p2 As StringApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualstartTime = Timer' 条件：距离小于 1300threshold = 1300' 使用 "03.Obj Geom - Point Coordinates" 作为数据来源工作表Set wsSource = ThisWorkbook.Worksheets("03.Obj Geom - Point Coordinates")' 根据 F 列确定最后一行（假设数据从第4行开始）lastRow = wsSource.Range("F" & wsSource.Rows.Count).End(xlUp).Row' 根据第3行确定最后一列（转置区域从 G 列开始）lastCol = wsSource.Cells(3, wsSource.Columns.Count).End(xlToLeft).Column' 读取矩阵区域：从单元格 G3（第3行第7列）到最后一行、最后一列' 注意：dataMatrix 第一行为标题（转置后的点名称），数据从第2行开始（对应工作表第4行以后）dataMatrix = wsSource.Range(wsSource.Cells(3, 7), wsSource.Cells(lastRow, lastCol)).Value' 另外读取参考点（位于 F 列），从第4行到最后一行point2Array = wsSource.Range(wsSource.Cells(4, 6), wsSource.Cells(lastRow, 6)).ValueitemCount = 0ReDim results(1 To 4, 1 To 1) ' 初始化结果数组，后续扩容使用Dim arrRowCount As Long, arrColCount As LongarrRowCount = UBound(dataMatrix, 1) ' dataMatrix 第一行对应工作表第3行（标题行）arrColCount = UBound(dataMatrix, 2)' 遍历数据矩阵（注意：数据从 dataMatrix 的第2行开始，对应工作表第4行以后）For i = 2 To arrRowCountFor j = 1 To arrColCount' 确保单元格内容为数字，且小于阈值并且不为 0If IsNumeric(dataMatrix(i, j)) ThenIf dataMatrix(i, j) < threshold And dataMatrix(i, j) <> 0 Then' 获取两点名称：' 点1：数据矩阵中对应列的标题' 点2：当前行 F 列的值（注意：point2Array 的行索引为 i-1，因为数据从工作表第4行开始）p1 = CStr(dataMatrix(1, j))p2 = CStr(point2Array(i - 1, 1))' 为避免重复记录（忽略顺序），仅在 p1 < p2（不区分大小写）时记录If StrComp(p1, p2, vbTextCompare) < 0 ThenitemCount = itemCount + 1ReDim Preserve results(1 To 4, 1 To itemCount)' 记录数据来源信息：' 1. 数据来源工作表名称results(1, itemCount) = "03.Obj Geom - Point Coordinates"' 2. 点1results(2, itemCount) = "'" & p1' 3. 点2results(3, itemCount) = "'" & p2' 4. 距离数值results(4, itemCount) = dataMatrix(i, j)End IfEnd IfEnd IfNext jNext i' 创建或清空结果工作表（新工作表命名为 "04. Distance check"）On Error Resume NextSet wsResult = ThisWorkbook.Worksheets("04. Distance check")If wsResult Is Nothing ThenSet wsResult = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsResult.Name = "04. Distance check"End IfOn Error GoTo 0wsResult.Cells.Clear' 将结果写入结果工作表With wsResult' 写入标题行.Range("A1") = "Sheet Name".Range("B1") = "Point 1".Range("C1") = "Point 2".Range("D1") = "Distance".Range("E1") = "Point 1_X".Range("F1") = "Point 1_Y".Range("G1") = "Point 2_X".Range("H1") = "Point 2_Y"If itemCount > 0 ThenDim k As LongFor k = 1 To itemCount.Cells(k + 1, 1) = results(1, k).Cells(k + 1, 2) = results(2, k).Cells(k + 1, 3) = results(3, k).Cells(k + 1, 4) = results(4, k)Next k' 利用 VLOOKUP 从源工作表 "03.Obj Geom - Point Coordinates" 的 A:D 区域获取点坐标信息.Range("E2").Formula = "=VLOOKUP($B2,'03.Obj Geom - Point Coordinates'!$A:$D,2,FALSE)".Range("F2").Formula = "=VLOOKUP($B2,'03.Obj Geom - Point Coordinates'!$A:$D,3,FALSE)".Range("G2").Formula = "=VLOOKUP($C2,'03.Obj Geom - Point Coordinates'!$A:$D,2,FALSE)".Range("H2").Formula = "=VLOOKUP($C2,'03.Obj Geom - Point Coordinates'!$A:$D,3,FALSE)"If itemCount > 1 Then.Range("E2:H2").AutoFill Destination:=.Range("E2:H" & itemCount + 1)End If' 格式化标题行和数据区域With .Range("A1:H1").Font.Bold = True.Interior.Color = RGB(200, 200, 200)End WithWith .Range("A1:H" & itemCount + 1).Borders.LineStyle = xlContinuous.Columns.AutoFitEnd With.Range("B:C").NumberFormat = "@".Range("A:A").HorizontalAlignment = xlCenterElse.Range("A2") = "No pairs with a distance less than " & threshold & " were found."End IfEnd WithApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticDim executionTime As StringexecutionTime = Format(Timer - startTime, "0.00")MsgBox itemCount & " pairs of points with a distance less than " & threshold & " were found (excluding zeros and duplicate pairs)." & vbNewLine & _"Execution time: " & executionTime & " seconds", vbInformation
End Sub
