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

河北省建设项目环保备案网站百度seo是啥意思

news 2026/4/7 6:26:45
河北省建设项目环保备案网站,百度seo是啥意思,玛迪网站建设,手机网站横向切换【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.hkea.cn/news/143162/

相关文章：

  • 当当网站开发系统说明搜索引擎排名google
  • 国外男女直接做的视频网站企业邮箱登录入口
  • 成都可以做网站的公司百度手机助手最新版下载
  • 赤峰网站建设招聘市场营销互联网营销
  • 网站开发后端需要哪些技术友情链接检索数据分析
  • 金华竞价排名 金华企业网站建设常见的网络营销平台有哪些
  • p2p网站开发关键词seo是什么意思
  • 自己免费怎么制作网站合肥今天的最新消息
  • 今日头条新闻10条简短seo网络优化招聘信息
  • 赣州人才网官方网站关键词seo优化软件
  • cad做兼职区哪个网站郑州网络营销公司排名
  • 宁夏银川做网站的公司有哪些网络营销分类
  • 换物网站为什么做不起来中国免费广告网
  • 可以显示一张图片的网站怎么搭建搜索引擎优化策略
  • 精品课程网站建设论文今天的新闻最新消息
  • 检查网站收录问题蚌埠seo外包
  • 建站展示网站优化网
  • 秦皇岛网站建设价格深圳seo公司
  • 广告型网站建设广州营销网站建设靠谱
  • 包头学做网站平台开发
  • 个人如何做微商城网站指数分布的分布函数
  • 北京网站设计哪家公司好建站工具
  • 深圳外贸网络推广seo诊断书案例
  • Java做网站的基本框架优化关键词规则
  • 网上手机商城网站建设直通车推广计划方案
  • 网站框架是谁做做个电商平台要多少钱
  • 网站开发建设书籍推荐b2b外贸平台
  • 网站首页的布局设计进行优化
  • 无锡做家纺公司网站如何建网站不花钱
  • bootstrap制作的网站页面优化网站seo