Ratings based on multiple rows in VBA only.

[MagnaForce]

I have a challenge for the Guru's here. I have been racking by brain trying to figure this one out. I need this to be done in VBA. I have explained how it works in the image. I cannot install the program that was listed when uploading an image, Strict company policy. I have been writing VBA for a couple of years be just cannot figure this one out. Please help.

 

[DanteAmor]

Welcome to the MrExcel Message Board!

Try the following code:

Sub Ratings()
  Dim dic As Object
  Dim a As Variant, b As Variant, n As Variant
  Dim i As Long
  
  a = Range("A2", Range("C" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    n = Application.Match(a(i, 3), Array("U", "M", "S"), 0)
    If Not IsError(n) Then
      If Not dic.exists(a(i, 1)) Then
        dic(a(i, 1)) = n & "|" & a(i, 3)
      Else
        If n < Val(Split(dic(a(i, 1)), "|")(0)) Then
          dic(a(i, 1)) = n & "|" & a(i, 3)
        End If
      End If
    End If
  Next
    
  For i = 1 To UBound(a)
    b(i, 1) = Split(dic(a(i, 1)), "|")(1)
  Next
  Range("B2").Resize(UBound(b)).Value = b
End Sub

 

[MagnaForce]

This worked perfect! Thanks. Now I just need to figure out how to modify to fit the actual columns in the real spreadsheet. This spreadsheet was used to solve the problem, which you did. I cannot thank you enough.

 

[MagnaForce]

In the spreadsheet I posted, the columns "A", "B" and "C" in the Actual spreadsheet that I need to use this VBA in the columns are as followed.
Column "A" is really Column "C" in the Actual spreadsheet
Column "B is really Column "F" in the Actual spreadsheet
Column "C" is really Column "M" in the Actual spreadsheet

Is this still possible? The spreadsheet was created by someone else and have been instructed to not move the columns around because other macros will be used also.
How can I buy you a Coffee or a Beer?

I tried changing the code to the following and it gave me an error.

Sub Ratings()
Dim dic As Object
Dim a As Variant, b As Variant, n As Variant
Dim i As Long

a = Range("C8", Range("M" & Rows.Count).End(3)).Value
ReDim b(1 To UBound(a, 1), 1 To 1)
Set dic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(a)
n = Application.Match(a(i, 3), Array("U", "M", "S"), 0)
If Not IsError Then
If Not dic.Exists(a(i, 1)) Then
dic(a(i, 1)) = n & "|" & a(i, 3)
Else
If n < Val(Split(dic(a(i, 1)), "|")(0)) Then
dic(a(i, 1)) = n & "|" & a(i, 3)
End If
End If
End If
Next

For i = 1 To UBound(a)
b(i, 1) = Split(dic(a(i, 1)), "|")(1)
Next
Range("F8").Resize(UBound(b)).Value = b
End Sub

 

[MagnaForce]

Sorry, I am new and just learning this web site I hope I did it correctly this time.

Sub Ratings()
  Dim dic As Object
  Dim a As Variant, b As Variant, n As Variant
  Dim i As Long
 
  a = Range("C8", Range("M" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    n = Application.Match(a(i, 3), Array("U", "M", "S"), 0)
    If Not IsError(n) Then
      If Not dic.Exists(a(i, 1)) Then
        dic(a(i, 1)) = n & "|" & a(i, 3)
      Else
        If n < Val(Split(dic(a(i, 1)), "|")(0)) Then
          dic(a(i, 1)) = n & "|" & a(i, 3)
        End If
      End If
    End If
  Next
    
  For i = 1 To UBound(a)
    b(i, 1) = Split(dic(a(i, 1)), "|")(1)
  Next
  Range("F8").Resize(UBound(b)).Value = b
End Sub

 

[DanteAmor]

Column "A" is really Column "C" in the Actual spreadsheet
Column "B is really Column "F" in the Actual spreadsheet
Column "C" is really Column "M" in the Actual spreadsheet

I adjusted the code and wrote some comments to make it more understandable.

Sub Ratings()
  Dim dic As Object
  Dim a As Variant, b As Variant, n As Variant
  Dim i As Long
  
  'Let's load into this matrix 'a' from column A to M. To make it easier,
  'although we don't need columns A and B. You will understand later.
  'And We look for the last row with data in column "Part" column "C"
  a = Range("A8:M" & Range("C" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    'So column A is 1 in matrix 'a', column B is 2 in matrix 'a',
    'column C is 3 in 'a', D is 4 in 'a' and so on .
    'Then M is the 13 in 'a'
    n = Application.Match(a(i, 13), Array("U", "M", "S"), 0)
    If Not IsError(n) Then
      If Not dic.exists(a(i, 3)) Then
        dic(a(i, 3)) = n & "|" & a(i, 13)
      Else
        If n < Val(Split(dic(a(i, 3)), "|")(0)) Then
          dic(a(i, 3)) = n & "|" & a(i, 13)
        End If
      End If
    End If
  Next
    
  For i = 1 To UBound(a)
    'The matrix 'b' only has one column, the output is stored in this matrix.
    b(i, 1) = Split(dic(a(i, 3)), "|")(1)
  Next
  Range("F8").Resize(UBound(b)).Value = b
End Sub

How can I buy you a Coffee or a Beer?

Sure a beer haha ?. Don't worry, just thanking and clicking like the publication is enough. Thanks for the kind intention.

 

[MagnaForce]

Thank you Sir. I really do appreciate your help and quick response. It works perfect now.
I added the line:

'This code was written By DanteAmor to the top of the macro to give credit to where credit is due.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.