Revision 346132313562 () - Diff

Link to this snippet: https://friendpaste.com/2HcrMkLVj8VbUfTrZXDCy2
Embed:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
442
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
921
93
941
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
1155
Sub Swap(a, x, y)
Dim i
Dim t
ReDim t(LBound(a, 1) To UBound(a, 1))
For i = LBound(a, 1) To UBound(a, 1)
t(i) = a(i, x)
Next
For i = LBound(a, 1) To UBound(a, 1)
a(i, x) = a(i, y)
Next
For i = LBound(a, 1) To UBound(a, 1)
a(i, y) = t(i)
Next
End Sub

Sub Sort(a, row, keys As Scripting.Dictionary)
Dim i
Dim j
For i = LBound(a, 1) To UBound(a, 1) - 1
For j = LBound(a, 1) To UBound(a, 1) - 1
If keys(a(row, j)) < keys(a(row, j + 1)) Then
Call Swap(a, j, j + 1)
End If
Next
Next
End Sub

Function GetSheet(rowNum As Long) As Excel.Worksheet
Set GetSheet = Excel.Worksheets(rowNum + 1)
End Function

Function GetRels_2(sh As Excel.Worksheet, c As String) As Scripting.Dictionary
Dim r As Scripting.Dictionary
Set r = New Scripting.Dictionary
Dim j As Long
Dim i As Excel.Range
For Each i In sh.Range("B1:D1").Columns
If i.Value = c Then
j = i.Column
Exit For
End If
Next
For Each i In sh.Range("A2:D4").Rows
Call r.Add(i.Columns(1).Value, i.Columns(j))
Next
Set GetRels_2 = r
End Function

Function GetRels(rowNum As Long, c As String) As Scripting.Dictionary
Set GetRels = GetRels_2(GetSheet(rowNum), c)
End Function

Function GetColor(r As Long) As Long
If r = 5 Then
GetColor = RGB(255, 0, 0)
ElseIf r = 3 Then
GetColor = RGB(255, 128, 128)
ElseIf r = 1 Then
GetColor = RGB(255, 192, 192)
ElseIf r = 0 Then
GetColor = RGB(255, 224, 224)
Else
Call Err.Raise(1, "invalid relative")
End If
End Function

Function GetColors_2(rels As Scripting.Dictionary) As Scripting.Dictionary
Dim c As Scripting.Dictionary
Set c = New Scripting.Dictionary
Dim i
For Each i In rels.keys
Call c.Add(i, GetColor(rels(i)))
Next
Set GetColors_2 = c
End Function

Function GetColors(rowNum As Long, c As String) As Scripting.Dictionary
Set GetColors = GetColors_2(GetRels(rowNum, c))
End Function

Sub Main()
Dim rowNum As Long
Dim char1 As String
rowNum = Excel.Selection.row
char1 = Excel.Selection.Value
' Sort
Dim v As Variant
Dim sh1 As Excel.Worksheet
Dim range1 As Excel.Range
Set sh1 = Excel.Worksheets(1)
Set range1 = sh1.Range("A1:C3")
v = range1.Value
Call Sort(v, 1, GetRels(rowNum, char1))
range1.Value = v
' Coloring
Dim c As Scripting.Dictionary
Dim i As Excel.Range
Dim j As Excel.Range
Dim colNum As Long
colNum = 1
For Each i In range1.Rows(rowNum).Columns
If i.Value = char1 Then
Exit For
End If
colNum = colNum + 1
Next
For Each i In range1.Rows
Set c = GetColors(i.row, i.Columns(colNum).Value)
For Each j In i.Columns
j.Interior.Color = c(j.Value)
Next
Next
End Sub