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

功能概述

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

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

流程图

关键方法详解

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 = 8For 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 WorksheetDim lastRow As LongDim i As Long, itemCount As LongDim dataArray() As VariantDim results() As VariantDim startTime As DoubleConst THRESHOLD_VALUE As Double = 1739 '设置阈值变量，方便修改Dim chtObj As ChartObjectApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualstartTime = Timer'Set up worksheetsSet wsSource = ThisWorkbook.Worksheets("Nodal Reactions")Set wsCoord = ThisWorkbook.Worksheets("Obj Geom - Point Coordinates")'Create or clear result worksheetOn Error Resume NextSet wsResult = ThisWorkbook.Worksheets("04.Over Points List")If wsResult Is Nothing ThenSet wsResult = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsResult.Name = "04.Over Points List"End IfOn Error GoTo 0wsResult.Cells.Clear'Get last row of source dataWith wsSourcelastRow = .Cells(.Rows.Count, "G").End(xlUp).Row'Read all data at oncedataArray = .Range(.Cells(1, 1), .Cells(lastRow, 10)).Value'Initialize results arrayitemCount = 0ReDim results(1 To 10, 1 To 1)'Process data arrayFor i = 2 To UBound(dataArray, 1)If IsNumeric(dataArray(i, 7)) ThenIf Abs(dataArray(i, 7)) > THRESHOLD_VALUE ThenitemCount = itemCount + 1ReDim Preserve results(1 To 10, 1 To itemCount)'Store all columnsFor j = 1 To 10results(j, itemCount) = dataArray(i, j)Next jEnd IfEnd IfNext iEnd With'Write resultsWith 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 foundIf itemCount > 0 Then'Write main dataFor i = 1 To itemCountFor j = 1 To 10.Cells(i + 1, j) = results(j, i)Next jNext 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 rowIf itemCount > 1 Then.Range("K2:M2").AutoFill Destination:=.Range("K2:M" & itemCount + 1)End If'Format the worksheetWith .Range("A1:M1").Font.Bold = True.Interior.Color = RGB(200, 200, 200)End WithWith .Range("A1:M" & itemCount + 1).Borders.LineStyle = xlContinuous.Columns.AutoFitEnd With.Range("A:D").NumberFormat = "@".Range("M:M").NumberFormat = "0.00%" '设置比值列为百分比格式'添加数据条条件格式Dim formatRange As RangeSet formatRange = .Range("M2:M" & itemCount + 1)formatRange.FormatConditions.DeleteformatRange.FormatConditions.AddDatabarWith formatRange.FormatConditions(1).BarFillType = xlDataBarFillSolid.BarColor.Color = RGB(255, 0, 0) 'Red color.ShowValue = TrueEnd With'删除现有图表（如果存在）On Error Resume NextwsResult.ChartObjects.DeleteOn 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.NewSeriesWith .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 = TrueWith .DataLabels.ShowValue = False.ShowCategoryName = False.ShowSeriesName = False.Format.TextFrame2.TextRange.Font.Size = 8'设置每个点的数据标签为对应的M列值On Error Resume Next  '添加错误处理Dim pt As IntegerFor pt = 1 To .Count.Item(pt).Text = Format(wsResult.Cells(pt + 1, "M").Value, "0.00%")Next ptOn Error GoTo 0End WithEnd With'设置图表标题和轴标题.HasTitle = True.ChartTitle.Text = "Distribution of Exceeding Points"With .Axes(xlCategory, xlPrimary).HasTitle = True.AxisTitle.Text = "X Coordinate"End WithWith .Axes(xlValue, xlPrimary).HasTitle = True.AxisTitle.Text = "Y Coordinate"End With'添加图例.HasLegend = FalseEnd WithEnd IfEnd With'Restore settingsApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomatic'Show completion messageDim executionTime As StringexecutionTime = Format(Timer - startTime, "0.00")If itemCount = 0 ThenMsgBox "No values exceeding " & THRESHOLD_VALUE & " were found in Column Fz." & vbNewLine & _"Execution time: " & executionTime & " seconds", vbInformationElseMsgBox itemCount & " values exceeding " & THRESHOLD_VALUE & " were found and listed." & vbNewLine & _"Execution time: " & executionTime & " seconds", vbInformationEnd 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 WorksheetDim lastRow As LongDim i As Long, itemCount As Long, itemCountLow As LongDim dataArray() As VariantDim results() As Variant, resultsLow() As VariantDim startTime As DoubleConst THRESHOLD_VALUE_HIGH As Double = 1850 '上限阈值Const THRESHOLD_VALUE_LOW As Double = 925  '下限阈值Dim chtObj As ChartObjectApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualstartTime = Timer'Set up worksheetsSet wsSource = ThisWorkbook.Worksheets("Nodal Reactions")Set wsCoord = ThisWorkbook.Worksheets("Obj Geom - Point Coordinates")'Create or clear result worksheetsOn Error Resume NextSet wsResult = ThisWorkbook.Worksheets("04.Over Points List")Set wsResultLow = ThisWorkbook.Worksheets("05.Lower Points List")If wsResult Is Nothing ThenSet wsResult = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsResult.Name = "04.Over Points List"End IfIf wsResultLow Is Nothing ThenSet wsResultLow = ThisWorkbook.Worksheets.Add(After:=wsResult)wsResultLow.Name = "05.Lower Points List"  ' 确保这里的名称与前面的Set语句一致End IfOn Error GoTo 0' 确保清除正确的工作表wsResult.Cells.ClearwsResultLow.Cells.Clear'Get last row of source dataWith wsSourcelastRow = .Cells(.Rows.Count, "G").End(xlUp).Row'Read all data at oncedataArray = .Range(.Cells(1, 1), .Cells(lastRow, 10)).Value'Initialize results arraysitemCount = 0itemCountLow = 0ReDim results(1 To 10, 1 To 1)ReDim resultsLow(1 To 10, 1 To 1)'Process data arrayFor i = 2 To UBound(dataArray, 1)If IsNumeric(dataArray(i, 7)) ThenIf Abs(dataArray(i, 7)) > THRESHOLD_VALUE_HIGH ThenitemCount = itemCount + 1ReDim Preserve results(1 To 10, 1 To itemCount)'Store all columns for high valuesFor j = 1 To 10results(j, itemCount) = dataArray(i, j)Next jElseIf Abs(dataArray(i, 7)) < THRESHOLD_VALUE_LOW ThenitemCountLow = itemCountLow + 1ReDim Preserve resultsLow(1 To 10, 1 To itemCountLow)'Store all columns for low valuesFor j = 1 To 10resultsLow(j, itemCountLow) = dataArray(i, j)Next jEnd IfEnd IfNext iEnd With'处理超过上限的数据ProcessWorksheet wsResult, results, itemCount, THRESHOLD_VALUE_HIGH, "Over"'处理低于下限的数据ProcessWorksheet wsResultLow, resultsLow, itemCountLow, THRESHOLD_VALUE_LOW, "Under"'Restore settingsApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomatic'Show completion messageDim executionTime As StringexecutionTime = 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 SubSub ProcessWorksheet(ws As Worksheet, results() As Variant, itemCount As Long, thresholdValue As Double, sheetType As String)Dim chtObj As ChartObjectDim j As LongWith 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 dataFor i = 1 To itemCountFor j = 1 To 10.Cells(i + 1, j) = results(j, i)Next jNext 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)/" & thresholdValueEnd If'Fill down formulas if more than one rowIf itemCount > 1 Then.Range("K2:M2").AutoFill Destination:=.Range("K2:M" & itemCount + 1)End If'Format the worksheetWith .Range("A1:M1").Font.Bold = True.Interior.Color = RGB(200, 200, 200)End WithWith .Range("A1:M" & itemCount + 1).Borders.LineStyle = xlContinuous.Columns.AutoFitEnd With.Range("A:D").NumberFormat = "@".Range("M:M").NumberFormat = "0.00%"'添加数据条条件格式Dim formatRange As RangeSet formatRange = .Range("M2:M" & itemCount + 1)formatRange.FormatConditions.DeleteformatRange.FormatConditions.AddDatabarWith formatRange.FormatConditions(1).BarFillType = xlDataBarFillSolidIf sheetType = "Over" Then.BarColor.Color = RGB(255, 0, 0) 'Red for over valuesElse.BarColor.Color = RGB(0, 0, 255) 'Blue for under valuesEnd If.ShowValue = TrueEnd With'删除现有图表（如果存在）On Error Resume Nextws.ChartObjects.DeleteOn 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.NewSeriesWith .SeriesCollection(1).XValues = ws.Range("K2:K" & itemCount + 1).Values = ws.Range("L2:L" & itemCount + 1).MarkerStyle = xlMarkerStyleCircle.MarkerSize = 8If sheetType = "Over" Then.Format.Fill.ForeColor.RGB = RGB(255, 0, 0)Else.Format.Fill.ForeColor.RGB = RGB(0, 0, 255)End If'为每个点添加数据标签.HasDataLabels = TrueWith .DataLabels.ShowValue = False.ShowCategoryName = False.ShowSeriesName = False.Format.TextFrame2.TextRange.Font.Size = 8On Error Resume NextDim pt As IntegerFor pt = 1 To .Count.Item(pt).Text = Format(ws.Cells(pt + 1, "M").Value, "0.00%")Next ptOn Error GoTo 0End WithEnd With'设置图表标题和轴标题.HasTitle = TrueIf sheetType = "Over" Then.ChartTitle.Text = "Distribution of Exceeding Points"Else.ChartTitle.Text = "Distribution of Lower Points"End IfWith .Axes(xlCategory, xlPrimary).HasTitle = True.AxisTitle.Text = "X Coordinate"End WithWith .Axes(xlValue, xlPrimary).HasTitle = True.AxisTitle.Text = "Y Coordinate"End With'添加图例.HasLegend = FalseEnd WithEnd IfEnd With
End Sub