chrisweirman
03-05-2009, 01:27 PM
Hi,
I've had some help with coding a maximum finder and it works well. I've modified it so that the values it looks
for contain a minimum threshold, using an input box if it needs to be changed.
The input method works fine but the if c.value > threshold_value in the code below returns values that are <0.1
(for instance) but still meet the second if statement (with the offsets). This should be an easy fix but I can't get
my head around it.
Sub findmax_working()
Dim c As Range
Dim i As Long
Dim shtcnt As Long
Dim column As Integer
column = -4
Dim threshold_value As Long
threshold_value = 0.1
If msgbox("Residuals threshold value set to 0.1. Do you want to change this?", vbYesNo _
+ vbDefaultButton2, "Threshold Value OK?") = vbYes Then
threshold_value = Application.InputBox("Please input new threshold value", "Threshold Value _
Input", 0.1, , , , , 1)
Else: End If
For Each s In ActiveWorkbook.Sheets
s.Activate
If s.Name <> "residuals" Then
i = 10
For Each c In Worksheets(s.Name).Range("b6:at91")
If c.Value > threshold_value Then
If c.Value > c.Offset(-1, -1).Value And c.Value > c.Offset(-1, 0).Value And c.Value > c.Offset _
(-1, 1).Value And c.Value > c.Offset(0, -1).Value And c.Value > c.Offset(0, 1).Value And c.Value _
> c.Offset(1, -1).Value And c.Value > c.Offset(1, 0).Value And c.Value >= c.Offset(1, 1).Value Then
With c.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Worksheets("residuals").Cells(i, column) = "Scan " & ActiveSheet.Name
Worksheets("residuals").Cells(i, column + 1) = "Anode " & i - 9
Worksheets("residuals").Cells(i, column + 2) = c.Value
Worksheets("residuals").Cells(i, column + 3).Formula = "=address(" & c.row & "," & c.column & ")"
i = i + 1
End If
End If
Next c
End If
column = column + 5
Next s
Worksheets("residuals").Activate
End Sub
Sub findmax_not_working()
Dim c As Range
Dim i As Long
Dim shtcnt As Long
Dim column As Integer
column = -4
Dim threshold_value As Long
threshold_value = 0.1
'If msgbox("Residuals threshold value set to 0.1. Do you want to change this?", _
vbYesNo + vbDefaultButton2, "Threshold Value OK?") = vbYes Then
'threshold_value = Application.InputBox("Please input new threshold value", _
"Threshold Value Input", 0.1, , , , , 1) 'Else:
End If
For Each s In ActiveWorkbook.Sheets
s.Activate
If s.Name <> "residuals" Then
i = 10
For Each c In Worksheets(s.Name).Range("b6:at91")
If c.Value > 0.1 Then
If c.Value > c.Offset(-1, -1).Value And c.Value > c.Offset(-1, 0).Value And c.Value > c.Offset _
(-1, 1).Value And c.Value > c.Offset(0, -1).Value And c.Value > c.Offset(0, 1).Value And _
c.Value > c.Offset(1, -1).Value And c.Value > c.Offset(1, 0).Value And c.Value >= c.Offset _
(1, 1).Value Then
With c.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Worksheets("residuals").Cells(i, column) = "Scan " & ActiveSheet.Name
Worksheets("residuals").Cells(i, column + 1) = "Anode " & i - 9
Worksheets("residuals").Cells(i, column + 2) = c.Value
Worksheets("residuals").Cells(i, column + 3).Formula = "=address(" & c.row & "," & c.column & ")"
i = i + 1
End If
End If
Next c
End If
column = column + 5
Next s
Worksheets("residuals").Activate
End Sub
Anybody?:dunno
I've had some help with coding a maximum finder and it works well. I've modified it so that the values it looks
for contain a minimum threshold, using an input box if it needs to be changed.
The input method works fine but the if c.value > threshold_value in the code below returns values that are <0.1
(for instance) but still meet the second if statement (with the offsets). This should be an easy fix but I can't get
my head around it.
Sub findmax_working()
Dim c As Range
Dim i As Long
Dim shtcnt As Long
Dim column As Integer
column = -4
Dim threshold_value As Long
threshold_value = 0.1
If msgbox("Residuals threshold value set to 0.1. Do you want to change this?", vbYesNo _
+ vbDefaultButton2, "Threshold Value OK?") = vbYes Then
threshold_value = Application.InputBox("Please input new threshold value", "Threshold Value _
Input", 0.1, , , , , 1)
Else: End If
For Each s In ActiveWorkbook.Sheets
s.Activate
If s.Name <> "residuals" Then
i = 10
For Each c In Worksheets(s.Name).Range("b6:at91")
If c.Value > threshold_value Then
If c.Value > c.Offset(-1, -1).Value And c.Value > c.Offset(-1, 0).Value And c.Value > c.Offset _
(-1, 1).Value And c.Value > c.Offset(0, -1).Value And c.Value > c.Offset(0, 1).Value And c.Value _
> c.Offset(1, -1).Value And c.Value > c.Offset(1, 0).Value And c.Value >= c.Offset(1, 1).Value Then
With c.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Worksheets("residuals").Cells(i, column) = "Scan " & ActiveSheet.Name
Worksheets("residuals").Cells(i, column + 1) = "Anode " & i - 9
Worksheets("residuals").Cells(i, column + 2) = c.Value
Worksheets("residuals").Cells(i, column + 3).Formula = "=address(" & c.row & "," & c.column & ")"
i = i + 1
End If
End If
Next c
End If
column = column + 5
Next s
Worksheets("residuals").Activate
End Sub
Sub findmax_not_working()
Dim c As Range
Dim i As Long
Dim shtcnt As Long
Dim column As Integer
column = -4
Dim threshold_value As Long
threshold_value = 0.1
'If msgbox("Residuals threshold value set to 0.1. Do you want to change this?", _
vbYesNo + vbDefaultButton2, "Threshold Value OK?") = vbYes Then
'threshold_value = Application.InputBox("Please input new threshold value", _
"Threshold Value Input", 0.1, , , , , 1) 'Else:
End If
For Each s In ActiveWorkbook.Sheets
s.Activate
If s.Name <> "residuals" Then
i = 10
For Each c In Worksheets(s.Name).Range("b6:at91")
If c.Value > 0.1 Then
If c.Value > c.Offset(-1, -1).Value And c.Value > c.Offset(-1, 0).Value And c.Value > c.Offset _
(-1, 1).Value And c.Value > c.Offset(0, -1).Value And c.Value > c.Offset(0, 1).Value And _
c.Value > c.Offset(1, -1).Value And c.Value > c.Offset(1, 0).Value And c.Value >= c.Offset _
(1, 1).Value Then
With c.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Worksheets("residuals").Cells(i, column) = "Scan " & ActiveSheet.Name
Worksheets("residuals").Cells(i, column + 1) = "Anode " & i - 9
Worksheets("residuals").Cells(i, column + 2) = c.Value
Worksheets("residuals").Cells(i, column + 3).Formula = "=address(" & c.row & "," & c.column & ")"
i = i + 1
End If
End If
Next c
End If
column = column + 5
Next s
Worksheets("residuals").Activate
End Sub
Anybody?:dunno