内蒙古自治区建设厅网站首页,9377传奇,深圳市做门窗网站有哪些推广,天津网站建设设计【Excel】【VBA】Reaction超限点筛选与散点图可视化 功能概述
这段代码实现了以下功能#xff1a;
从SAFE输出的结果worksheet通过datalink获取更新数据从指定工作表中读取数据检测超过阈值的数据点生成结果表格并添加格式化创建可视化散点图显示执行时间
流程图 #mermaid-…【Excel】【VBA】Reaction超限点筛选与散点图可视化 功能概述
这段代码实现了以下功能
从SAFE输出的结果worksheet通过datalink获取更新数据从指定工作表中读取数据检测超过阈值的数据点生成结果表格并添加格式化创建可视化散点图显示执行时间
流程图 #mermaid-svg-O0bhMOsHxH9bgzmX {font-family:"trebuchet ms",verdana,arial,sans-serif;font-size:16px;fill:#333;}#mermaid-svg-O0bhMOsHxH9bgzmX .error-icon{fill:#552222;}#mermaid-svg-O0bhMOsHxH9bgzmX .error-text{fill:#552222;stroke:#552222;}#mermaid-svg-O0bhMOsHxH9bgzmX .edge-thickness-normal{stroke-width:2px;}#mermaid-svg-O0bhMOsHxH9bgzmX .edge-thickness-thick{stroke-width:3.5px;}#mermaid-svg-O0bhMOsHxH9bgzmX .edge-pattern-solid{stroke-dasharray:0;}#mermaid-svg-O0bhMOsHxH9bgzmX .edge-pattern-dashed{stroke-dasharray:3;}#mermaid-svg-O0bhMOsHxH9bgzmX .edge-pattern-dotted{stroke-dasharray:2;}#mermaid-svg-O0bhMOsHxH9bgzmX .marker{fill:#333333;stroke:#333333;}#mermaid-svg-O0bhMOsHxH9bgzmX .marker.cross{stroke:#333333;}#mermaid-svg-O0bhMOsHxH9bgzmX svg{font-family:"trebuchet ms",verdana,arial,sans-serif;font-size:16px;}#mermaid-svg-O0bhMOsHxH9bgzmX .label{font-family:"trebuchet ms",verdana,arial,sans-serif;color:#333;}#mermaid-svg-O0bhMOsHxH9bgzmX .cluster-label text{fill:#333;}#mermaid-svg-O0bhMOsHxH9bgzmX .cluster-label span{color:#333;}#mermaid-svg-O0bhMOsHxH9bgzmX .label text,#mermaid-svg-O0bhMOsHxH9bgzmX span{fill:#333;color:#333;}#mermaid-svg-O0bhMOsHxH9bgzmX .node rect,#mermaid-svg-O0bhMOsHxH9bgzmX .node circle,#mermaid-svg-O0bhMOsHxH9bgzmX .node ellipse,#mermaid-svg-O0bhMOsHxH9bgzmX .node polygon,#mermaid-svg-O0bhMOsHxH9bgzmX .node path{fill:#ECECFF;stroke:#9370DB;stroke-width:1px;}#mermaid-svg-O0bhMOsHxH9bgzmX .node .label{text-align:center;}#mermaid-svg-O0bhMOsHxH9bgzmX .node.clickable{cursor:pointer;}#mermaid-svg-O0bhMOsHxH9bgzmX .arrowheadPath{fill:#333333;}#mermaid-svg-O0bhMOsHxH9bgzmX .edgePath .path{stroke:#333333;stroke-width:2.0px;}#mermaid-svg-O0bhMOsHxH9bgzmX .flowchart-link{stroke:#333333;fill:none;}#mermaid-svg-O0bhMOsHxH9bgzmX .edgeLabel{background-color:#e8e8e8;text-align:center;}#mermaid-svg-O0bhMOsHxH9bgzmX .edgeLabel rect{opacity:0.5;background-color:#e8e8e8;fill:#e8e8e8;}#mermaid-svg-O0bhMOsHxH9bgzmX .cluster rect{fill:#ffffde;stroke:#aaaa33;stroke-width:1px;}#mermaid-svg-O0bhMOsHxH9bgzmX .cluster text{fill:#333;}#mermaid-svg-O0bhMOsHxH9bgzmX .cluster span{color:#333;}#mermaid-svg-O0bhMOsHxH9bgzmX div.mermaidTooltip{position:absolute;text-align:center;max-width:200px;padding:2px;font-family:"trebuchet ms",verdana,arial,sans-serif;font-size:12px;background:hsl(80, 100%, 96.2745098039%);border:1px solid #aaaa33;border-radius:2px;pointer-events:none;z-index:100;}#mermaid-svg-O0bhMOsHxH9bgzmX :root{--mermaid-font-family:"trebuchet ms",verdana,arial,sans-serif;} 初始化 是 否 开始 读取数据 检测超限值 是否有超限点? 创建结果表格 添加格式化 创建散点图 恢复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 8For 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).RowV20250121
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 TimerSet 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 ListEnd IfOn Error GoTo 0wsResult.Cells.ClearGet last row of source dataWith wsSourcelastRow .Cells(.Rows.Count, G).End(xlUp).RowRead all data at oncedataArray .Range(.Cells(1, 1), .Cells(lastRow, 10)).ValueInitialize 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 WithWrite resultsWith wsResultWrite 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 ThenWrite main dataFor i 1 To itemCountFor j 1 To 10.Cells(i 1, j) results(j, i)Next jNext iAdd 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 -1Fill down formulas if more than one rowIf itemCount 1 Then.Range(K2:M2).AutoFill Destination:.Range(K2:M itemCount 1)End IfFormat 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 PointsWith .Axes(xlCategory, xlPrimary).HasTitle True.AxisTitle.Text X CoordinateEnd WithWith .Axes(xlValue, xlPrimary).HasTitle True.AxisTitle.Text Y CoordinateEnd With添加图例.HasLegend FalseEnd WithEnd IfEnd WithRestore settingsApplication.ScreenUpdating TrueApplication.Calculation xlCalculationAutomaticShow 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 1000 下限阈值Dim chtObj As ChartObjectApplication.ScreenUpdating FalseApplication.Calculation xlCalculationManualstartTime TimerSet 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.Under Points List)If wsResult Is Nothing ThenSet wsResult ThisWorkbook.Worksheets.Add(After:ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsResult.Name 04.Over Points ListEnd IfIf wsResultLow Is Nothing ThenSet wsResultLow ThisWorkbook.Worksheets.Add(After:wsResult)wsResultLow.Name 05.Lower Points ListEnd IfOn Error GoTo 0wsResult.Cells.ClearwsResultLow.Cells.ClearGet last row of source dataWith wsSourcelastRow .Cells(.Rows.Count, G).End(xlUp).RowRead all data at oncedataArray .Range(.Cells(1, 1), .Cells(lastRow, 10)).ValueInitialize 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, UnderRestore settingsApplication.ScreenUpdating TrueApplication.Calculation xlCalculationAutomaticShow 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 wsWrite 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 ThenWrite main dataFor i 1 To itemCountFor j 1 To 10.Cells(i 1, j) results(j, i)Next jNext iAdd 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 -1Else.Range(M2).Formula 1-ABS(G2)/ thresholdValueEnd IfFill down formulas if more than one rowIf itemCount 1 Then.Range(K2:M2).AutoFill Destination:.Range(K2:M itemCount 1)End IfFormat 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 PointsElse.ChartTitle.Text Distribution of Lower PointsEnd IfWith .Axes(xlCategory, xlPrimary).HasTitle True.AxisTitle.Text X CoordinateEnd WithWith .Axes(xlValue, xlPrimary).HasTitle True.AxisTitle.Text Y CoordinateEnd With添加图例.HasLegend FalseEnd WithEnd IfEnd With
End Sub
