当前位置： 首页 > news >正文

网站开发策划书互动营销平台

news 2025/7/9 17:22:09
网站开发策划书,互动营销平台,电商网站总体设计方案,中卫网站设计厂家【Excel】【VBA】Reaction超限点筛选与散点图可视化 功能概述 这段代码实现了以下功能： 从SAFE输出的结果worksheet通过datalink获取更新数据从指定工作表中读取数据检测超过阈值的数据点生成结果表格并添加格式化创建可视化散点图显示执行时间 流程图 #mermaid-…

【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 = 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
  1. 计时功能实现
startTime = Timer
executionTime = Format(Timer - startTime, "0.00")
  1. 动态范围处理
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 = 1000  '下限阈值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.Under 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"End IfOn Error GoTo 0wsResult.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
http://www.zhongyajixie.com/news/4754.html

相关文章：

  • wordpress导航栏固定在顶部汕头seo关键词排名
  • 百度网站建设电话seogw
  • 怎么做网站扫描seo外链推广员
  • 深圳网站建设哪家便宜惠州搜索引擎seo
  • 学院管理网站建设有哪些网络营销公司
  • 智能自助建站网站怎样在网上推广
  • 做视频找空镜头那个网站比较全网络广告营销方案策划
  • 在线做公章网站杭州做seo的公司
  • 广州网站设计公司兴田德润在哪儿最近刚发生的新闻
  • 做app和做网站的区别新网站百度收录要几天
  • 淄博铭锐 网站建设小吃培训2000元学6项
  • 国内b2b平台有哪几个赣州seo唐三
  • 哪些公司的网站做的漂亮百度标注平台怎么加入
  • 自建营销型网站模板软文营销的概念
  • 哪个公司做网站好苏州电商网站搭建
  • 找图片素材网站网站免费推广的方法
  • 网站建设与搜索引擎营销的关系网络营销论坛
  • 党员写试卷需要在哪个网站做长春seo技术
  • wordpress自定义背景颜色seo关键词优化报价价格
  • wordpress issingular安卓优化软件
  • 做淘宝联盟网站用数据库吗六年级下册数学优化设计答案
  • 嘉兴品牌网站建设青岛百度seo排名
  • 品牌网站建设维护搜索引擎排名优化程序
  • 制作网站的网站今日头条极速版最新
  • 如何自制一个网站西seo优化排名
  • 青岛建设网站设计公司杭州全网推广
  • 自己做网站挣钱不seo顾问服务深圳
  • 织梦医疗网站杭州网站优化企业
  • 论坛网站模板下载市场营销实际案例
  • 网站头部图片如何做东营网站推广公司