查找距离阈值下的点对及坐标提取
1. 需求分析
这个 VBA 程序的主要目标是：
- 从工作表中查找距离小于指定阈值的点对
- 记录这些点对的信息和距离
- 通过 VLOOKUP 函数提取点对的坐标信息
- 将结果格式化输出到新工作表
2. 程序流程图
是 否 开始 禁用屏幕刷新和自动计算 设置参数和工作表 读取数据到数组 遍历数据矩阵 距离 < 阈值? 记录点对信息 创建结果工作表 写入数据和公式 格式化结果 启用屏幕刷新和自动计算 显示执行结果 结束
3. 关键 VBA 技术点解析
3.1 性能优化技术
vba
' 禁用屏幕刷新和自动计算以提升性能
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual3.2 数组操作
vba
' 声明动态数组
Dim dataMatrix() As Variant
' 从工作表读取数据到数组
dataMatrix = wsSource.Range(...).Value
' 动态调整数组大小
ReDim Preserve results(1 To 4, 1 To itemCount)3.3 工作表操作
vba
' 错误处理和工作表创建
On Error Resume Next
Set wsResult = ThisWorkbook.Worksheets("04. Distance check")
If wsResult Is Nothing Then
Set wsResult = ThisWorkbook.Worksheets.Add
wsResult.Name = "04. Distance check"
End If
On Error GoTo 03.4 Excel 公式应用
vba
' 使用 VLOOKUP 函数获取坐标信息
.Range("E2").Formula = "=VLOOKUP($B2,'03.Obj Geom - Point Coordinates'!$A:$D,2,FALSE)"4. 代码结构详解
4.1 变量声明部分
vba
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 数据读取部分
vba
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 数据处理部分
vba
For i = 2 To arrRowCount
For j = 1 To arrColCount
If IsNumeric(dataMatrix(i, j)) Then
If dataMatrix(i, j) < threshold And dataMatrix(i, j) <> 0 Then
' 处理逻辑
End If
End If
Next j
Next i- 使用嵌套循环遍历数据
- 使用条件判断筛选有效数据
5. 实用技巧
5.1 使用计时器
vba
startTime = Timer
' ... 代码执行 ...
executionTime = Format(Timer - startTime, "0.00")5.2 数组动态扩展
vba
ReDim Preserve results(1 To 4, 1 To itemCount)5.3 单元格格式化
vba
With .Range("A1:H1")
.Font.Bold = True
.Interior.Color = RGB(200, 200, 200)
End With
c
Sub FindUnderDistanceValues()
Dim wsSource As Worksheet, wsResult As Worksheet
Dim lastRow As Long, lastCol As Long
Dim i As Long, j As Long
Dim dataMatrix() As Variant
Dim point2Array() As Variant
Dim results() As Variant
Dim itemCount As Long
Dim threshold As Double
Dim startTime As Double
Dim p1 As String, p2 As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
startTime = Timer
' 条件：距离小于 1300
threshold = 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)).Value
itemCount = 0
ReDim results(1 To 4, 1 To 1) ' 初始化结果数组，后续扩容使用
Dim arrRowCount As Long, arrColCount As Long
arrRowCount = UBound(dataMatrix, 1) ' dataMatrix 第一行对应工作表第3行（标题行）
arrColCount = UBound(dataMatrix, 2)
' 遍历数据矩阵（注意：数据从 dataMatrix 的第2行开始，对应工作表第4行以后）
For i = 2 To arrRowCount
For j = 1 To arrColCount
' 确保单元格内容为数字，且小于阈值并且不为 0
If IsNumeric(dataMatrix(i, j)) Then
If 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 Then
itemCount = itemCount + 1
ReDim Preserve results(1 To 4, 1 To itemCount)
' 记录数据来源信息：
' 1. 数据来源工作表名称
results(1, itemCount) = "03.Obj Geom - Point Coordinates"
' 2. 点1
results(2, itemCount) = "'" & p1
' 3. 点2
results(3, itemCount) = "'" & p2
' 4. 距离数值
results(4, itemCount) = dataMatrix(i, j)
End If
End If
End If
Next j
Next i
' 创建或清空结果工作表（新工作表命名为 "04. Distance check"）
On Error Resume Next
Set wsResult = ThisWorkbook.Worksheets("04. Distance check")
If wsResult Is Nothing Then
Set wsResult = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsResult.Name = "04. Distance check"
End If
On Error GoTo 0
wsResult.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 Then
Dim k As Long
For 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 With
With .Range("A1:H" & itemCount + 1)
.Borders.LineStyle = xlContinuous
.Columns.AutoFit
End With
.Range("B:C").NumberFormat = "@"
.Range("A:A").HorizontalAlignment = xlCenter
Else
.Range("A2") = "No pairs with a distance less than " & threshold & " were found."
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Dim executionTime As String
executionTime = 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