Snasui Excel Forum

Code: Select all

Sub SumPern()
Dim a As Variant, b As Variant
Dim k As Integer, i As Integer
Dim t As Integer, u As Integer
Dim r As Range, ra As Range
Dim rl As Range, rall As Range
a = Array("N", "R", "RW", "M", "F", "D")
b = Array(0, 1, 2, 3, 4, 5)
With ActiveSheet
    Set rall = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    For Each rl In rall
        u = 0
        If rl = "Sum-Perm" Then
            k = rl.Row - rl.Offset(0, -1).End(xlUp).Row
            Set ra = rl.Offset(-k, 1).Resize(k, 1)
            For Each r In ra
                For i = 0 To UBound(a)
                    If r = a(i) Then
                        t = b(i)
                    End If
                    If t >= u Then
                        u = t
                    End If
                Next i
            Next r
            rl.Offset(0, 1) = a(u)
        End If
      Next rl
End With
End Sub

Code: Select all

Public Sub SumPern()
Dim a As Variant, b As Variant
Dim k As Integer, i As Integer
Dim t As Integer, u As Integer
Dim r As Range, ra As Range
Dim rl As Range, rall As Range
Dim j As Integer
a = Array("N", "R", "RW", "M", "F", "D")
b = Array(0, 1, 2, 3, 4, 5)
With ActiveSheet
    Set rall = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    For Each rl In rall
        If rl = "Sum-Perm" Then
            k = rl.Row - rl.Offset(0, -1).End(xlUp).Row
            For j = 0 To 3
                u = 0
                t = 0
                Set ra = rl.Offset(-k, 1 + j).Resize(k, 1)
                For Each r In ra
                    For i = 0 To UBound(a)
                        If r = a(i) Then
                            t = b(i)
                        End If
                        If t >= u Then
                            u = t
                        End If
                    Next i
                Next r
                rl.Offset(0, j + 1) = a(u)
            Next j
        End If
      Next rl
End With
End Sub