【Excel】【VBA】Reaction超限点筛选与散点图可视化

【Excel】【VBA】Reaction超限点筛选与散点图可视化

功能概述

这段代码实现了以下功能：

1. 从SAFE输出的结果worksheet通过datalink获取更新数据
2. 从指定工作表中读取数据
3. 检测超过阈值的数据点
4. 生成结果表格并添加格式化
5. 创建可视化散点图
6. 显示执行时间

流程图

初始化 是 否 开始 读取数据 检测超限值 是否有超限点? 创建结果表格 添加格式化 创建散点图 恢复Excel设置 显示执行时间 结束

关键方法详解

1. 性能优化技巧

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

• 禁用屏幕更新和自动计算，提高执行效率
• 完成后需要恢复这些设置

2. 数组操作

dataArray = .Range(.Cells(1, 1), .Cells(lastRow, 10)).Value
ReDim Preserve results(1 To 10, 1 To itemCount)

• 使用数组批量读取数据，比逐单元格读取更快
• ReDim Preserve 允许动态调整数组大小同时保留现有数据

3. 错误处理

On Error Resume Next
' 代码块
On Error GoTo 0

• 使用错误处理确保代码稳定性
• 可以优雅地处理工作表不存在等异常情况

4. 条件格式化

formatRange.FormatConditions.AddDatabar
With formatRange.FormatConditions(1)
    .BarFillType = xlDataBarFillSolid
    .BarColor.Color = RGB(255, 0, 0)
End With

• 添加数据条来可视化超限比率
• 使用RGB颜色定义来设置格式

5. 图表创建

Set chtObj = wsResult.ChartObjects.Add(...)
With chtObj.Chart
    .ChartType = xlXYScatter
    .SeriesCollection.NewSeries
    ' 设置数据源和格式
End With

• 使用ChartObjects创建图表对象
• 设置图表类型、数据源和格式化选项

6. 数据标签

With .DataLabels
    .ShowValue = False
    .Format.TextFrame2.TextRange.Font.Size = 8
    For pt = 1 To .Count
        .Item(pt).Text = Format(wsResult.Cells(pt + 1, "M").Value, "0.00%")
    Next pt
End With

• 为散点添加自定义数据标签
• 使用Format函数格式化百分比显示

学习要点

1. 数据处理效率

   • 使用数组批量处理数据
   • 禁用不必要的Excel功能提升性能

2. 代码结构

   • 使用With语句块简化代码
   • 合理组织代码逻辑，提高可读性

3. 错误处理

   • 在关键操作处添加错误处理
   • 确保程序稳定运行

4. Excel对象模型

   • 理解工作表、单元格范围的操作
   • 掌握图表对象的创建和设置

5. 可视化技巧

   • 条件格式化的应用
   • 散点图的创建和自定义

实用技巧

1. 使用常量定义关键值

Const THRESHOLD_VALUE As Double = 1739

2. 计时功能实现

startTime = Timer
executionTime = Format(Timer - startTime, "0.00")

3. 动态范围处理

lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row

V20250121

Sub FindExceedingValues()
    Dim wsSource As Worksheet, wsCoord As Worksheet, wsResult As Worksheet
    Dim lastRow As Long
    Dim i As Long, itemCount As Long
    Dim dataArray() As Variant
    Dim results() As Variant
    Dim startTime As Double
    Const THRESHOLD_VALUE As Double = 1739 '设置阈值变量，方便修改
    Dim chtObj As ChartObject
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    startTime = Timer
    
    'Set up worksheets
    Set wsSource = ThisWorkbook.Worksheets("Nodal Reactions")
    Set wsCoord = ThisWorkbook.Worksheets("Obj Geom - Point Coordinates")
    
    'Create or clear result worksheet
    On Error Resume Next
    Set wsResult = ThisWorkbook.Worksheets("04.Over Points List")
    If wsResult Is Nothing Then
        Set wsResult = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsResult.Name = "04.Over Points List"
    End If
    On Error GoTo 0
    
    wsResult.Cells.Clear
    
    'Get last row of source data
    With wsSource
        lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        
        'Read all data at once
        dataArray = .Range(.Cells(1, 1), .Cells(lastRow, 10)).Value
        
        'Initialize results array
        itemCount = 0
        ReDim results(1 To 10, 1 To 1)
        
        'Process data array
        For i = 2 To UBound(dataArray, 1)
            If IsNumeric(dataArray(i, 7)) Then
                If Abs(dataArray(i, 7)) > THRESHOLD_VALUE Then
                    itemCount = itemCount + 1
                    ReDim Preserve results(1 To 10, 1 To itemCount)
                    
                    'Store all columns
                    For j = 1 To 10
                        results(j, itemCount) = dataArray(i, j)
                    Next j
                End If
            End If
        Next i
    End With
    
    'Write results
    With wsResult
        'Write headers
        .Range("A1:J1") = Array("Node", "Point", "OutputCase", "CaseType", "Fx", "Fy", "Fz", "Mx", "My", "Mz")
        .Range("K1") = "X Coordinate"
        .Range("L1") = "Y Coordinate"
        .Range("M1") = "Exceeding Ratio" '新增列标题
        
        'Write data if any found
        If itemCount > 0 Then
            'Write main data
            For i = 1 To itemCount
                For j = 1 To 10
                    .Cells(i + 1, j) = results(j, i)
                Next j
            Next i
            
            'Add VLOOKUP formulas
            .Range("K2").Formula = "=VLOOKUP($B2,'Obj Geom - Point Coordinates'!$A:$C,2,FALSE)"
            .Range("L2").Formula = "=VLOOKUP($B2,'Obj Geom - Point Coordinates'!$A:$C,3,FALSE)"
            
            '添加比值计算公式
            .Range("M2").Formula = "=ABS(G2)/" & THRESHOLD_VALUE & "-1"
            
            'Fill down formulas if more than one row
            If itemCount > 1 Then
                .Range("K2:M2").AutoFill Destination:=.Range("K2:M" & itemCount + 1)
            End If
            
            'Format the worksheet
            With .Range("A1:M1")
                .Font.Bold = True
                .Interior.Color = RGB(200, 200, 200)
            End With
            
            With .Range("A1:M" & itemCount + 1)
                .Borders.LineStyle = xlContinuous
                .Columns.AutoFit
            End With
            
            .Range("A:D").NumberFormat = "@"
            .Range("M:M").NumberFormat = "0.00%" '设置比值列为百分比格式
            
            '添加数据条条件格式
            Dim formatRange As Range
            Set formatRange = .Range("M2:M" & itemCount + 1)
            formatRange.FormatConditions.Delete
            formatRange.FormatConditions.AddDatabar
            With formatRange.FormatConditions(1)
                .BarFillType = xlDataBarFillSolid
                .BarColor.Color = RGB(255, 0, 0) 'Red color
                .ShowValue = True
            End With
            
            '删除现有图表（如果存在）
            On Error Resume Next
            wsResult.ChartObjects.Delete
            On Error GoTo 0
            
        '创建散点图
        Set chtObj = wsResult.ChartObjects.Add( _
            Left:=.Range("O1").Left, _
            Top:=.Range("O1").Top, _
            Width:=800, _
            Height:=600)
        
        With chtObj.Chart
            .ChartType = xlXYScatter
            
            '添加数据系列
            .SeriesCollection.NewSeries
            With .SeriesCollection(1)
                .XValues = wsResult.Range("K2:K" & itemCount + 1)
                .Values = wsResult.Range("L2:L" & itemCount + 1)
                .MarkerStyle = xlMarkerStyleCircle
                .MarkerSize = 8
                .Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
                
                '为每个点添加数据标签
                .HasDataLabels = True
                With .DataLabels
                    .ShowValue = False
                    .ShowCategoryName = False
                    .ShowSeriesName = False
                    .Format.TextFrame2.TextRange.Font.Size = 8
                    
                    '设置每个点的数据标签为对应的M列值
                    On Error Resume Next  '添加错误处理
                    Dim pt As Integer
                    For pt = 1 To .Count
                        .Item(pt).Text = Format(wsResult.Cells(pt + 1, "M").Value, "0.00%")
                    Next pt
                    On Error GoTo 0
                End With
            End With
            
            '设置图表标题和轴标题
            .HasTitle = True
            .ChartTitle.Text = "Distribution of Exceeding Points"
            
            With .Axes(xlCategory, xlPrimary)
                .HasTitle = True
                .AxisTitle.Text = "X Coordinate"
            End With
            
            With .Axes(xlValue, xlPrimary)
                .HasTitle = True
                .AxisTitle.Text = "Y Coordinate"
            End With
            
            '添加图例
            .HasLegend = False
        End With
        End If
    End With
    
    'Restore settings
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    'Show completion message
    Dim executionTime As String
    executionTime = Format(Timer - startTime, "0.00")
    
    If itemCount = 0 Then
        MsgBox "No values exceeding " & THRESHOLD_VALUE & " were found in Column Fz." & vbNewLine & _
               "Execution time: " & executionTime & " seconds", vbInformation
    Else
        MsgBox itemCount & " values exceeding " & THRESHOLD_VALUE & " were found and listed." & vbNewLine & _
               "Execution time: " & executionTime & " seconds", vbInformation
    End If
End Sub

V20250122 add lower point list (for reduncancy reference)

Sub FindExceedingValues()
    Dim wsSource As Worksheet, wsCoord As Worksheet, wsResult As Worksheet, wsResultLow As Worksheet
    Dim lastRow As Long
    Dim i As Long, itemCount As Long, itemCountLow As Long
    Dim dataArray() As Variant
    Dim results() As Variant, resultsLow() As Variant
    Dim startTime As Double
    Const THRESHOLD_VALUE_HIGH As Double = 1850 '上限阈值
    Const THRESHOLD_VALUE_LOW As Double = 925  '下限阈值
    Dim chtObj As ChartObject
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    startTime = Timer
    
    'Set up worksheets
    Set wsSource = ThisWorkbook.Worksheets("Nodal Reactions")
    Set wsCoord = ThisWorkbook.Worksheets("Obj Geom - Point Coordinates")
    
    'Create or clear result worksheets
    On Error Resume Next
    Set wsResult = ThisWorkbook.Worksheets("04.Over Points List")
    Set wsResultLow = ThisWorkbook.Worksheets("05.Lower Points List")
    
    If wsResult Is Nothing Then
        Set wsResult = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsResult.Name = "04.Over Points List"
    End If
    
    If wsResultLow Is Nothing Then
        Set wsResultLow = ThisWorkbook.Worksheets.Add(After:=wsResult)
        wsResultLow.Name = "05.Lower Points List"  ' 确保这里的名称与前面的Set语句一致
    End If
    On Error GoTo 0
    
    ' 确保清除正确的工作表
    wsResult.Cells.Clear
    wsResultLow.Cells.Clear
    
    'Get last row of source data
    With wsSource
        lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        
        'Read all data at once
        dataArray = .Range(.Cells(1, 1), .Cells(lastRow, 10)).Value
        
        'Initialize results arrays
        itemCount = 0
        itemCountLow = 0
        ReDim results(1 To 10, 1 To 1)
        ReDim resultsLow(1 To 10, 1 To 1)
        
        'Process data array
        For i = 2 To UBound(dataArray, 1)
            If IsNumeric(dataArray(i, 7)) Then
                If Abs(dataArray(i, 7)) > THRESHOLD_VALUE_HIGH Then
                    itemCount = itemCount + 1
                    ReDim Preserve results(1 To 10, 1 To itemCount)
                    
                    'Store all columns for high values
                    For j = 1 To 10
                        results(j, itemCount) = dataArray(i, j)
                    Next j
                ElseIf Abs(dataArray(i, 7)) < THRESHOLD_VALUE_LOW Then
                    itemCountLow = itemCountLow + 1
                    ReDim Preserve resultsLow(1 To 10, 1 To itemCountLow)
                    
                    'Store all columns for low values
                    For j = 1 To 10
                        resultsLow(j, itemCountLow) = dataArray(i, j)
                    Next j
                End If
            End If
        Next i
    End With
    
    '处理超过上限的数据
    ProcessWorksheet wsResult, results, itemCount, THRESHOLD_VALUE_HIGH, "Over"
    
    '处理低于下限的数据
    ProcessWorksheet wsResultLow, resultsLow, itemCountLow, THRESHOLD_VALUE_LOW, "Under"
    
    'Restore settings
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    'Show completion message
    Dim executionTime As String
    executionTime = Format(Timer - startTime, "0.00")
    
    MsgBox "Found " & itemCount & " values exceeding " & THRESHOLD_VALUE_HIGH & vbNewLine & _
           "Found " & itemCountLow & " values below " & THRESHOLD_VALUE_LOW & vbNewLine & _
           "Execution time: " & executionTime & " seconds", vbInformation
End Sub

Sub ProcessWorksheet(ws As Worksheet, results() As Variant, itemCount As Long, thresholdValue As Double, sheetType As String)
    Dim chtObj As ChartObject
    Dim j As Long
    
    With ws
        'Write headers
        .Range("A1:J1") = Array("Node", "Point", "OutputCase", "CaseType", "Fx", "Fy", "Fz", "Mx", "My", "Mz")
        .Range("K1") = "X Coordinate"
        .Range("L1") = "Y Coordinate"
        .Range("M1") = "Ratio" '新增列标题
        
        If itemCount > 0 Then
            'Write main data
            For i = 1 To itemCount
                For j = 1 To 10
                    .Cells(i + 1, j) = results(j, i)
                Next j
            Next i
            
            'Add VLOOKUP formulas
            .Range("K2").Formula = "=VLOOKUP($B2,'Obj Geom - Point Coordinates'!$A:$C,2,FALSE)"
            .Range("L2").Formula = "=VLOOKUP($B2,'Obj Geom - Point Coordinates'!$A:$C,3,FALSE)"
            
            '添加比值计算公式
            If sheetType = "Over" Then
                .Range("M2").Formula = "=ABS(G2)/" & thresholdValue & "-1"
            Else
                .Range("M2").Formula = "=1-ABS(G2)/" & thresholdValue
            End If
            
            'Fill down formulas if more than one row
            If itemCount > 1 Then
                .Range("K2:M2").AutoFill Destination:=.Range("K2:M" & itemCount + 1)
            End If
            
            'Format the worksheet
            With .Range("A1:M1")
                .Font.Bold = True
                .Interior.Color = RGB(200, 200, 200)
            End With
            
            With .Range("A1:M" & itemCount + 1)
                .Borders.LineStyle = xlContinuous
                .Columns.AutoFit
            End With
            
            .Range("A:D").NumberFormat = "@"
            .Range("M:M").NumberFormat = "0.00%"
            
            '添加数据条条件格式
            Dim formatRange As Range
            Set formatRange = .Range("M2:M" & itemCount + 1)
            formatRange.FormatConditions.Delete
            formatRange.FormatConditions.AddDatabar
            With formatRange.FormatConditions(1)
                .BarFillType = xlDataBarFillSolid
                If sheetType = "Over" Then
                    .BarColor.Color = RGB(255, 0, 0) 'Red for over values
                Else
                    .BarColor.Color = RGB(0, 0, 255) 'Blue for under values
                End If
                .ShowValue = True
            End With
            
            '删除现有图表（如果存在）
            On Error Resume Next
            ws.ChartObjects.Delete
            On Error GoTo 0
            
            '创建散点图
            Set chtObj = ws.ChartObjects.Add( _
                Left:=.Range("O1").Left, _
                Top:=.Range("O1").Top, _
                Width:=800, _
                Height:=600)
            
            With chtObj.Chart
                .ChartType = xlXYScatter
                
                '添加数据系列
                .SeriesCollection.NewSeries
                With .SeriesCollection(1)
                    .XValues = ws.Range("K2:K" & itemCount + 1)
                    .Values = ws.Range("L2:L" & itemCount + 1)
                    .MarkerStyle = xlMarkerStyleCircle
                    .MarkerSize = 8
                    If sheetType = "Over" Then
                        .Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
                    Else
                        .Format.Fill.ForeColor.RGB = RGB(0, 0, 255)
                    End If
                    
                    '为每个点添加数据标签
                    .HasDataLabels = True
                    With .DataLabels
                        .ShowValue = False
                        .ShowCategoryName = False
                        .ShowSeriesName = False
                        .Format.TextFrame2.TextRange.Font.Size = 8
                        
                        On Error Resume Next
                        Dim pt As Integer
                        For pt = 1 To .Count
                            .Item(pt).Text = Format(ws.Cells(pt + 1, "M").Value, "0.00%")
                        Next pt
                        On Error GoTo 0
                    End With
                End With
                
                '设置图表标题和轴标题
                .HasTitle = True
                If sheetType = "Over" Then
                    .ChartTitle.Text = "Distribution of Exceeding Points"
                Else
                    .ChartTitle.Text = "Distribution of Lower Points"
                End If
                
                With .Axes(xlCategory, xlPrimary)
                    .HasTitle = True
                    .AxisTitle.Text = "X Coordinate"
                End With
                
                With .Axes(xlValue, xlPrimary)
                    .HasTitle = True
                    .AxisTitle.Text = "Y Coordinate"
                End With
                
                '添加图例
                .HasLegend = False
            End With
        End If
    End With
End Sub