Ranking matrix by value and corresponding name (over time)

F

FloFlo

New Member
Joined
Jun 20, 2018
Messages
12
I would like to rank a matrix by value (with corresponding name) per time period. Also, as the matrix will be a bit larger, I would like to indicate every person with a different color. That way one can easily see how each and everyone performed over time. So in the result, the background of Davis would be green for instance, Smith would be yellow and Jones red.

As an example:

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]Monday[/TD]
[TD]Tuesday[/TD]
[TD]Wednesday[/TD]
[/TR]
[TR]
[TD]Smith[/TD]
[TD]5[/TD]
[TD]9[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]Jones[/TD]
[TD]6[/TD]
[TD]2[/TD]
[TD]8[/TD]
[/TR]
[TR]
[TD]Davis[/TD]
[TD]8[/TD]
[TD]7[/TD]
[TD]4[/TD]
[/TR]
</tbody>[/TABLE]

Desired result:
[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]Monday[/TD]
[TD]Teusday[/TD]
[TD]Wednesday[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Davis
8[/TD]
[TD]Smith
9[/TD]
[TD]Jones
8[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Jones
6[/TD]
[TD]Davis
7[/TD]
[TD]Davis
4[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Smith
5[/TD]
[TD]Jones
2[/TD]
[TD]Smith
3[/TD]
[/TR]
</tbody>[/TABLE]

So far the best way for me to do this was by hand as I did above, although I would like automate this process as results may differ on a daily basis.
Also, thusfar I am not able to assign names to numbers and colors in the same (or different) cell.

I hope this is clear. I would greatly appreciate any help.

Thanks,
Floris
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
Say you have data starting from A1, run the below script, you will see the result from A20 onwards.

Sub Macro3()


Dim i, j As Long
Sheets("Sheet1").Select
i = Range("A1").CurrentRegion.Rows.Count
j = Range("A1").CurrentRegion.Columns.Count

Range("B2").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & i), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(Cells(1, 1), Cells(i, j))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


Range(Cells(1, 1), Cells(1, j)).Select
Application.CutCopyMode = False
Selection.Copy
Range("A20").Select
ActiveSheet.Paste

For k = 2 To j

Range("A1:A" & i).Select
Application.CutCopyMode = False
Selection.Copy
Range("P1").Select
ActiveSheet.Paste

Range(Cells(1, k), Cells(i, k)).Select
Application.CutCopyMode = False
Selection.Copy
Range("Q1").Select
ActiveSheet.Paste

Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("Q2:Q" & i), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("P1:Q" & i)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Range("R2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
Range("R2").Select
Selection.AutoFill Destination:=Range("R2:R" & i), Type:=xlFillDefault
Range("R2:R" & i).Select
Selection.Copy
Range(Cells(21, k), Cells(20 + i, k)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Next
Range("P1:S" & i).Select
Application.CutCopyMode = False
Selection.ClearContents
End Sub
 
Upvote 0
Try this for results on sheet2.
NB:- I have not coloured the Results cells because if you have many names you soon run out of useful colours and many light colours become hard to read.
If you really want the colours I can provide them , but do a trial colouring first to see what is acceptable (font or Interior colour).

Code: 
[COLOR="Navy"]Sub[/COLOR] MG20Jun08
[COLOR="Navy"]Dim[/COLOR] ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, R [COLOR="Navy"]As[/COLOR] Variant, Col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] St, Sa [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
ray = ActiveSheet.Cells(1).CurrentRegion
ReDim nRay(1 To UBound(ray, 1) * 3, 1 To UBound(ray, 2))
[COLOR="Navy"]For[/COLOR] ac = 2 To UBound(ray, 2)
    c = 1
    [COLOR="Navy"]With[/COLOR] CreateObject("System.Collections.ArrayList")
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
        [COLOR="Navy"]For[/COLOR] n = 2 To UBound(ray, 1)
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(ray(n, ac)) [COLOR="Navy"]Then[/COLOR]
                Dic.Add ray(n, ac), n
                .Add ray(n, ac)
            [COLOR="Navy"]Else[/COLOR]
            Dic(ray(n, ac)) = Dic(ray(n, ac)) & "," & n
            .Add ray(n, ac)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
        .Sort: .Reverse
        R = .toarray: c = 1
        nRay(1, ac - 1) = ray(1, ac)

[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
    
    [COLOR="Navy"]For[/COLOR] Sa = 0 To UBound(R)
        [COLOR="Navy"]If[/COLOR] Not Temp = R(Sa) [COLOR="Navy"]Then[/COLOR]
            Sp = Split(Dic(R(Sa)), ",")
                [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                    c = c + 1
                    nRay(c, ac - 1) = ray(Sp(n), 1)
                    c = c + 1
                    nRay(c, ac - 1) = R(Sa)
                [COLOR="Navy"]Next[/COLOR] n
                Temp = R(Sa)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Sa
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] ac
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, UBound(ray, 2) - 1)
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick, you're a lifesaver! Thank you so much.
It looks really great, although I could really use the colors (preferably in RGB scale) so one can easily see how the rank is (as a color is easier to recognise than a words).
Thank you!
 
Upvote 0
You're welcome
Try this Complete code for added colour in sheet 2.

Code: 
[COLOR="Navy"]Sub[/COLOR] MG20Jun09
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, R [COLOR="Navy"]As[/COLOR] Variant, Col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] St, Sa [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
Ray = ActiveSheet.Cells(1).CurrentRegion
ReDim nRay(1 To UBound(Ray, 1) * 3, 1 To UBound(Ray, 2))
[COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
    c = 1
    [COLOR="Navy"]With[/COLOR] CreateObject("System.Collections.ArrayList")
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
        [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
                Dic.Add Ray(n, Ac), n
                .Add Ray(n, Ac)
            [COLOR="Navy"]Else[/COLOR]
            Dic(Ray(n, Ac)) = Dic(Ray(n, Ac)) & "," & n
            .Add Ray(n, Ac)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
        .Sort: .Reverse
        R = .toarray: c = 1
        nRay(1, Ac - 1) = Ray(1, Ac)
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
    
    [COLOR="Navy"]For[/COLOR] Sa = 0 To UBound(R)
        [COLOR="Navy"]If[/COLOR] Not Temp = R(Sa) [COLOR="Navy"]Then[/COLOR]
            Sp = Split(Dic(R(Sa)), ",")
                [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                    c = c + 1
                    nRay(c, Ac - 1) = Ray(Sp(n), 1)
                    c = c + 1
                    nRay(c, Ac - 1) = R(Sa)
                [COLOR="Navy"]Next[/COLOR] n
                Temp = R(Sa)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Sa
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] Ac
 [COLOR="Navy"]Set[/COLOR] Rng = Sheets("Sheet2").Range("A1").Resize(c, UBound(Ray, 2) - 1)
 
 [COLOR="Navy"]With[/COLOR] Rng
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
Newcols Rng, Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
 
[COLOR="Navy"]Sub[/COLOR] Newcols(nRng [COLOR="Navy"]As[/COLOR] Range, sRay)
[COLOR="Navy"]Dim[/COLOR] rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] fCol [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(sRay, 1): Dic(sRay(n, 1)) = Dic.Count: [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]For[/COLOR] Ac = 1 To nRng.Columns.Count
    [COLOR="Navy"]For[/COLOR] rw = 2 To nRng.Rows.Count [COLOR="Navy"]Step[/COLOR] 2
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dic(nRng(rw, Ac).Value)
            [COLOR="Navy"]Case[/COLOR] 2, 6, 15, 19, 20, 22, 24, 27, 34, 35, 36, 37, 38, 39, 40, 43, 44, 45, 46, 51, 52: fCol = 1
            [COLOR="Navy"]Case[/COLOR] Else: fCol = 2
        [COLOR="Navy"]End[/COLOR] Select
        nRng(rw, Ac).Interior.ColorIndex = Dic(nRng(rw, Ac).Value)
        nRng(rw + 1, Ac).Interior.ColorIndex = Dic(nRng(rw, Ac).Value)
        nRng(rw, Ac).Font.ColorIndex = fCol
        nRng(rw + 1, Ac).Font.ColorIndex = fCol
    [COLOR="Navy"]Next[/COLOR] rw
[COLOR="Navy"]Next[/COLOR] Ac
nRng.Font.Bold = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,
Thank you for your response, though I am not able to see any colors in my sheet, the outcome remains te same as the (awesome) first code you wrote.
So if all Smith (and corresponding values) would carry the RGB color scale ( 0/0/255). Jones would get (255/0/0) and Davis (0/255/0).
How would I implement this in the code above?
Thank you for your time!!
Floris
 
Upvote 0
At the end of the latest bit of code there is a Sub to colour sheet 2 data (see below). Have you got that in your code module ????

Code: 
[COLOR=#000080]Sub[/COLOR] Newcols(nRng [COLOR=navy]As[/COLOR] Range, sRay)
[COLOR=navy]Dim[/COLOR] rw [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] fCol [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Dic [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
    [COLOR=navy]For[/COLOR] n = 1 To UBound(sRay, 1): Dic(sRay(n, 1)) = Dic.Count: [COLOR=navy]Next[/COLOR] n
[COLOR=navy]For[/COLOR] Ac = 1 To nRng.Columns.Count
    [COLOR=navy]For[/COLOR] rw = 2 To nRng.Rows.Count [COLOR=navy]Step[/COLOR] 2
        [COLOR=navy]Select[/COLOR] [COLOR=navy]Case[/COLOR] Dic(nRng(rw, Ac).Value)
            [COLOR=navy]Case[/COLOR] 2, 6, 15, 19, 20, 22, 24, 27, 34, 35, 36, 37, 38, 39, 40, 43, 44, 45, 46, 51, 52: fCol = 1
            [COLOR=navy]Case[/COLOR] Else: fCol = 2
        [COLOR=navy]End[/COLOR] Select
        nRng(rw, Ac).Interior.ColorIndex = Dic(nRng(rw, Ac).Value)
        nRng(rw + 1, Ac).Interior.ColorIndex = Dic(nRng(rw, Ac).Value)
        nRng(rw, Ac).Font.ColorIndex = fCol
        nRng(rw + 1, Ac).Font.ColorIndex = fCol
    [COLOR=navy]Next[/COLOR] rw
[COLOR=navy]Next[/COLOR] Ac
nRng.Font.Bold = True
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
 
Upvote 0
Hi Mick,
Thank you for your fast response. It worked!
Still, is there a way to personalize the colours in RGB scale?
Many thanks!
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Countif to show result show only once per match
Replies
3
Views
217
Cubist
Cubist
C
  • Question Question
Using a common value, display unique values that relate/correspond to it
Replies
8
Views
725
chive90
C
B
  • Question Question
VBA to show and change list of names depending on selection
Replies
7
Views
727
mumps
mumps
SFCChase
  • Solved
Multiple Criteria Ranking
Replies
2
Views
1K
SFCChase
SFCChase
N
  • Question Question
Auto Scoring Matrix
Replies
4
Views
669
Eric W
Eric W

Forum statistics

Threads
1,223,099
Messages
6,170,108
Members
452,302
Latest member
TaMere

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top