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 Sub
V20250110
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 1results(3, itemCount)="'"&dataArray(i,3) 'Point 2results(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 Sub
