【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
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
