【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
相关推荐
Goona_5 小时前
拒绝SQL恐惧:用Python+pyqt打造任意Excel数据库查询系统
数据库·python·sql·excel·pyqt
忘忧记5 小时前
excel删除重复项场景
excel
UrbanJazzerati8 小时前
Excel 神器 COUNTIFS 函数详解:多条件计数实战
excel
想学习java初学者1 天前
SpringBoot整合Fastexcel/EasyExcel导出Excel导出单个图片
excel
LAM LAB1 天前
【WPS】office邮件合并,怎么将数据源excel中的下一条拼接在文档中的下一个位置
excel·wps
SEO-狼术1 天前
Document Solutions for Excel, .NET
excel
Access开发易登软件2 天前
Access开发一键删除Excel指定工作表
服务器·前端·后端·excel·vba·access·access开发
Saggitarxm3 天前
Golang实现 - 实现只有表头的 Excel 模板,并在指定列添加了下拉框功能。生成的 Excel 文件在打开时,指定列的单元格会显示下拉选项
excel·下拉框选项序列·生成excel模板·下拉框选项
pk_xz1234563 天前
SAP全自动化工具开发:Excel自动上传与邮件通知系统
运维·人工智能·windows·深度学习·分类·自动化·excel
俊昭喜喜里4 天前
Excel——设置打印的区域
excel