文章目录
- VBA函数与方法简介
-
- [1. 工作表操作 (Worksheet Operations)](#1. 工作表操作 (Worksheet Operations))
- [2. 应用程序控制 (Application Control)](#2. 应用程序控制 (Application Control))
- [3. 数组操作 (Array Operations)](#3. 数组操作 (Array Operations))
- [4. 格式化 (Formatting)](#4. 格式化 (Formatting))
- [5. 公式和填充 (Formulas and Fill)](#5. 公式和填充 (Formulas and Fill))
- [6. 错误处理 (Error Handling)](#6. 错误处理 (Error Handling))
- 关键功能点 (Key Features)
-
- [1. 性能优化 (Performance Optimization)](#1. 性能优化 (Performance Optimization))
- [2. 数据处理 (Data Processing)](#2. 数据处理 (Data Processing))
- [3. 格式化 (Formatting)](#3. 格式化 (Formatting))
- [4. 用户反馈 (User Feedback)](#4. 用户反馈 (User Feedback))
V20250109
c
Sub FindExceedingValues()
Dim wsMax As Worksheet, wsMin As Worksheet, wsResult As Worksheet
Dim lastRow As Long, lastCol As Long
Dim i As Long, j As Long, resultRow As Long
Dim point1 As String, point2 As String
Dim startRow As Long
'Set up worksheets
Set wsMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")
Set wsMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")
'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
'Add headers
wsResult.Range("A1") = "Sheet Name"
wsResult.Range("B1") = "Point 1"
wsResult.Range("C1") = "Point 2"
wsResult.Range("D1") = "Value"
resultRow = 2
'Process Max sheet
With wsMax
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
lastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
startRow = resultRow
For i = 4 To lastRow
For j = 13 To lastCol 'Starting from column M (13)
If IsNumeric(.Cells(i, j).Value) Then
If .Cells(i, j).Value > 0.002 Then
point1 = "'" & .Cells(3, j).Text 'Use .Text to keep original format
point2 = "'" & .Cells(i, "C").Text
wsResult.Cells(resultRow, "A").Value = "Max"
wsResult.Cells(resultRow, "B").Value = point1
wsResult.Cells(resultRow, "C").Value = point2
wsResult.Cells(resultRow, "D").Value = .Cells(i, j).Value
resultRow = resultRow + 1
End If
End If
Next j
Next i
'Merge Max sheet cells if there are results
If resultRow > startRow Then
wsResult.Range("A" & startRow & ":A" & resultRow - 1).Merge
End If
End With
'Process Min sheet
With wsMin
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
lastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
startRow = resultRow
For i = 4 To lastRow
For j = 13 To lastCol 'Starting from column M (13)
If IsNumeric(.Cells(i, j).Value) Then
If .Cells(i, j).Value > 0.002 Then
point1 = "'" & .Cells(3, j).Text 'Use .Text to keep original format
point2 = "'" & .Cells(i, "C").Text
wsResult.Cells(resultRow, "A").Value = "Min"
wsResult.Cells(resultRow, "B").Value = point1
wsResult.Cells(resultRow, "C").Value = point2
wsResult.Cells(resultRow, "D").Value = .Cells(i, j).Value
resultRow = resultRow + 1
End If
End If
Next j
Next i
'Merge Min sheet cells if there are results
If resultRow > startRow Then
wsResult.Range("A" & startRow & ":A" & resultRow - 1).Merge
End If
End With
'Format result sheet
With wsResult
If resultRow > 2 Then 'If we have results
With .Range("A1:D1")
.Font.Bold = True
.Interior.Color = RGB(200, 200, 200)
End With
.Range("A1:D" & resultRow - 1).Borders.LineStyle = xlContinuous
'Set text format for Point columns
.Range("B:C").NumberFormat = "@"
.Columns.AutoFit
'Center the merged cells
.Range("A:A").HorizontalAlignment = xlCenter
.Range("A:A").VerticalAlignment = xlCenter
End If
End With
'Show completion message
If resultRow = 2 Then
MsgBox "No values exceeding 0.002 were found.", vbInformation
Else
MsgBox resultRow - 2 & " values exceeding 0.002 were found and listed.", vbInformation
End If
End SubV20250110
c
Sub FindExceedingValues()
Dim wsMax As Worksheet, wsMin As Worksheet, wsResult As Worksheet
Dim lastRow As Long, lastCol As Long
Dim i As Long, j As Long, resultRow As Long
Dim point1 As String, point2 As String
Dim dataArray() As Variant
Dim results() As Variant
Dim startTime As Double
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
startTime = Timer
'Set up worksheets
Set wsMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")
Set wsMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")
'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
'Process both sheets
Dim sheetArray(1 To 2) As Worksheet
Set sheetArray(1) = wsMax
Set sheetArray(2) = wsMin
Dim itemCount As Long: itemCount = 0
ReDim results(1 To 4, 1 To 1) ' Initialize with minimum size
For Each ws In sheetArray
Dim sheetName As String
sheetName = IIf(ws Is wsMax, "Max", "Min")
With ws
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
lastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
'Read all data at once
dataArray = .Range(.Cells(3, 1), .Cells(lastRow, lastCol)).Value
'Process data array
For i = 2 To UBound(dataArray, 1) 'Start from row 4 (array index 2)
For j = 13 To UBound(dataArray, 2)
If IsNumeric(dataArray(i, j)) Then
If dataArray(i, j) > 0.002 Then
itemCount = itemCount + 1
ReDim Preserve results(1 To 4, 1 To itemCount)
results(1, itemCount) = sheetName
results(2, itemCount) = "'" & dataArray(1, j) 'Point 1
results(3, itemCount) = "'" & dataArray(i, 3) 'Point 2
results(4, itemCount) = dataArray(i, j) 'Value
End If
End If
Next j
Next i
End With
Next ws
'Write headers
With wsResult
.Range("A1") = "Sheet Name"
.Range("B1") = "Point 1"
.Range("C1") = "Point 2"
.Range("D1") = "Value"
.Range("E1") = "Point 1_X"
.Range("F1") = "Point 1_Y"
.Range("G1") = "Point 2_X"
.Range("H1") = "Point 2_Y"
'Write results if any found
If itemCount > 0 Then
'Write data
For i = 1 To itemCount
.Cells(i + 1, 1) = results(1, i)
.Cells(i + 1, 2) = results(2, i)
.Cells(i + 1, 3) = results(3, i)
.Cells(i + 1, 4) = results(4, i)
Next i
'Add formulas for coordinates
.Range("E2").Formula = "=VLOOKUP($B2,'03.Obj Geom - Point Coordinates'!$A:$D,2,FALSE)"
.Range("F2").Formula = "=VLOOKUP($B2,'03.Obj Geom - Point Coordinates'!$A:$D,3,FALSE)"
.Range("G2").Formula = "=VLOOKUP($C2,'03.Obj Geom - Point Coordinates'!$A:$D,2,FALSE)"
.Range("H2").Formula = "=VLOOKUP($C2,'03.Obj Geom - Point Coordinates'!$A:$D,3,FALSE)"
'Fill down formulas
If itemCount > 1 Then
.Range("E2:H2").AutoFill Destination:=.Range("E2:H" & itemCount + 1)
End If
'Format the worksheet
With .Range("A1:H1")
.Font.Bold = True
.Interior.Color = RGB(200, 200, 200)
End With
With .Range("A1:H" & itemCount + 1)
.Borders.LineStyle = xlContinuous
.Columns.AutoFit
End With
.Range("B:C").NumberFormat = "@"
.Range("A:A").HorizontalAlignment = xlCenter
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 0.002 were found." & vbNewLine & _
"Execution time: " & executionTime & " seconds", vbInformation
Else
MsgBox itemCount & " values exceeding 0.002 were found and listed." & vbNewLine & _
"Execution time: " & executionTime & " seconds", vbInformation
End If
End SubDiagram
Process flow
开始 初始化变量和设置 禁用屏幕刷新和自动计算 获取工作表引用 创建/清理结果工作表 处理Max和Min工作表 获取数据范围 读取数据到数组 遍历数据查找>0.002的值 将结果存入数组 写入表头 写入数据 添加VLOOKUP公式 格式化工作表 恢复Excel设置 显示完成消息 结束
VBA函数与方法简介
1. 工作表操作 (Worksheet Operations)
Worksheets- 访问工作表集合Cells- 访问单元格Range- 访问单元格范围End(xlUp)- 查找已使用区域的末尾
2. 应用程序控制 (Application Control)
Application.ScreenUpdating- 控制屏幕更新Application.Calculation- 控制计算模式Timer- 获取系统时间
3. 数组操作 (Array Operations)
ReDim Preserve- 重新调整数组大小并保留数据UBound- 获取数组上界
4. 格式化 (Formatting)
Font.Bold- 设置字体粗细Interior.Color- 设置单元格背景色NumberFormat- 设置数字格式Borders- 设置边框AutoFit- 自动调整列宽
5. 公式和填充 (Formulas and Fill)
Formula- 设置单元格公式AutoFill- 自动填充公式
6. 错误处理 (Error Handling)
On Error Resume Next- 忽略错误继续执行On Error GoTo 0- 恢复正常错误处理
关键功能点 (Key Features)
1. 性能优化 (Performance Optimization)
- 使用数组批量读取和处理数据 (Array batch processing)
- 关闭屏幕更新和自动计算 (Screen updating control)
- 使用With语句减少对象引用 (Object reference reduction)
2. 数据处理 (Data Processing)
- 遍历工作表数据 (Worksheet data iteration)
- 条件筛选 (Condition filtering)
- 使用VLOOKUP查找坐标数据 (VLOOKUP coordinate search)
3. 格式化 (Formatting)
- 设置表头样式 (Header styling)
- 添加边框 (Border addition)
- 调整列宽 (Column width adjustment)
- 设置数字格式 (Number format setting)
4. 用户反馈 (User Feedback)
- 显示处理结果统计 (Result statistics display)
- 显示执行时间 (Execution time display)