PDA

View Full Version : Help with my code (Finding specific max values and applying it for other column)



tzexu1610
03-15-2018, 01:59 AM
Hello,

I've got a dataset of many stores, with each stores having 2 varians (A and B).

Ive been asked to do a few tasks and have written a code to get a few of them done but I am now stuck.

1) Remove all #VALUE! (done)

2) absolute value all z score (done)

2) If there is a zscore outlier, highlight its corresponding result (done). outlier is if the absolute value is > 3

3) I now need to find the sole maximum value under zscore (excluding the already selected outliers), and highlight its corresponding result. but i cant seem to continue on my code for that.

this is my code:


Sub Stage1()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

Dim i As Integer
Dim j As Integer
Dim a As Long
Dim myLastRow As Integer
Dim myLastColumn As Integer

i = 10 'Start Row
j = 3 'Z-score column

myLastRow = Range("A" & Rows.Count).End(xlUp).Row

'remove error'
For a = 1 To 2
On Error Resume Next
Cells(a, j).SpecialCells(xlCellTypeFormulas, 16).ClearContents
On Error GoTo 0
Next a

'Stage 1 outlier removal
j = -1
Do
j = j + 4
Do
If Cells(i, j - 1).Errors.Item(xlNumberAsText).Value = False Then 'result NOT stored as text'
If (Cells(i, j).Value >= -3 And Cells(i, j) <= 3) Then 'not outlier'
i = i + 1
ElseIf IsEmpty(Cells(i, j)) = True Then 'Skip blank cell'
i = i + 1
Else
Cells(i, j - 1).Value = "'" & Cells(i, j - 1).Value 'Result is now text'
i = 10 'restart at first row
End If
Else
i = i + 1
End If
Loop Until i > myLastRow
Loop Until Cells(9, j).Value = ""

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub



Sub Stage2()

Application.ScreenUpdating = False
Application.DisplayStatusBar = False

Dim i As Integer
Dim j As Integer
Dim a As Long
Dim b As Long
Dim myLastRow As Integer
Dim myLastColumn As Integer
Dim Absolute As Double
Dim Absolute2 As Double

i = 10 'Start Row
j = 3 'Z-score column

myLastRow = Range("A" & Rows.Count).End(xlUp).Row

'remove error'
For a = 1 To 2
On Error Resume Next
Cells(a, j).SpecialCells(xlCellTypeFormulas, 16).ClearContents
On Error GoTo 0
Next a

'Stage 2 outlier check'
j = -1
j = j + 4

'absolute value everything'
For b = 1 To myLastRow
Cells(i, j).Value = Abs(Cells(i, j).Value)
Next b

j = j - 1

Do
j = j + 4
Do
If Cells(i, j - 1).Errors.Item(xlNumberAsText).Value = False Then 'result NOT stored as text'
If (Cells(i, j).Value < 3) Then 'not outlier'
i = i + 1
ElseIf IsEmpty(Cells(i, j)) = True Then 'Skip blank cell'
i = i + 1
Else
Cells(i, j - 1).Value = "'" & Cells(i, j - 1).Value 'Result is now text'
i = 10 'restart at first row
End If
Else
i = i + 1
End If
Loop Until i > myLastRow
Loop Until Cells(9, j).Value = ""

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Function
End Sub




any help would be greatly appreciated