【EXCEL】【VBA】查找sheet中小于阈值的值并提取单元格对应的行列对应编号（Distance Check查找距离过小的点对）

查找距离阈值下的点对及坐标提取

1. 需求分析

这个 VBA 程序的主要目标是：

从工作表中查找距离小于指定阈值的点对
记录这些点对的信息和距离
通过 VLOOKUP 函数提取点对的坐标信息
将结果格式化输出到新工作表

2. 程序流程图

是否开始禁用屏幕刷新和自动计算设置参数和工作表读取数据到数组遍历数据矩阵距离 < 阈值? 记录点对信息创建结果工作表写入数据和公式格式化结果启用屏幕刷新和自动计算显示执行结果结束

3. 关键 VBA 技术点解析

3.1 性能优化技术

vba 复制代码

' 禁用屏幕刷新和自动计算以提升性能
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

3.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 0

3.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