【Excel】【VBA】Reaction超限点筛选与散点图可视化
【Excel】【VBA】Reaction超限点筛选与散点图可视化
功能概述
这段代码实现了以下功能：
- 从SAFE输出的结果worksheet通过datalink获取更新数据
- 从指定工作表中读取数据
- 检测超过阈值的数据点
- 生成结果表格并添加格式化
- 创建可视化散点图
- 显示执行时间
流程图
关键方法详解
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函数格式化百分比显示
学习要点
-
数据处理效率
- 使用数组批量处理数据
- 禁用不必要的Excel功能提升性能
-
代码结构
- 使用With语句块简化代码
- 合理组织代码逻辑，提高可读性
-
错误处理
- 在关键操作处添加错误处理
- 确保程序稳定运行
-
Excel对象模型
- 理解工作表、单元格范围的操作
- 掌握图表对象的创建和设置
-
可视化技巧
- 条件格式化的应用
- 散点图的创建和自定义
实用技巧
- 使用常量定义关键值
Const THRESHOLD_VALUE As Double = 1739
- 计时功能实现
startTime = Timer
executionTime = Format(Timer - startTime, "0.00")
- 动态范围处理
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