2HcrMkLVj8VbUfTrZXDCy2 changeset

Changeset346132313562 (b)
ParentNone (a)
ab
0+Sub Swap(a, x, y)
0+    Dim i
0+    Dim t
0+    ReDim t(LBound(a, 1) To UBound(a, 1))
0+    For i = LBound(a, 1) To UBound(a, 1)
0+        t(i) = a(i, x)
0+    Next
0+    For i = LBound(a, 1) To UBound(a, 1)
0+        a(i, x) = a(i, y)
0+    Next
0+    For i = LBound(a, 1) To UBound(a, 1)
0+        a(i, y) = t(i)
0+    Next
0+End Sub
0+
0+Sub Sort(a, row, keys As Scripting.Dictionary)
0+    Dim i
0+    Dim j
0+    For i = LBound(a, 1) To UBound(a, 1) - 1
0+        For j = LBound(a, 1) To UBound(a, 1) - 1
0+            If keys(a(row, j)) < keys(a(row, j + 1)) Then
0+                Call Swap(a, j, j + 1)
0+            End If
0+        Next
0+    Next
0+End Sub
0+
0+Function GetSheet(rowNum As Long) As Excel.Worksheet
0+    Set GetSheet = Excel.Worksheets(rowNum + 1)
0+End Function
0+
0+Function GetRels_2(sh As Excel.Worksheet, c As String) As Scripting.Dictionary
0+    Dim r As Scripting.Dictionary
0+    Set r = New Scripting.Dictionary
0+    Dim j As Long
0+    Dim i As Excel.Range
0+    For Each i In sh.Range("B1:D1").Columns
0+        If i.Value = c Then
0+            j = i.Column
0+            Exit For
0+        End If
0+    Next
0+    For Each i In sh.Range("A2:D4").Rows
0+        Call r.Add(i.Columns(1).Value, i.Columns(j))
0+    Next
0+    Set GetRels_2 = r
0+End Function
0+
0+Function GetRels(rowNum As Long, c As String) As Scripting.Dictionary
0+    Set GetRels = GetRels_2(GetSheet(rowNum), c)
0+End Function
0+
0+Function GetColor(r As Long) As Long
0+    If r = 5 Then
0+        GetColor = RGB(255, 0, 0)
0+    ElseIf r = 3 Then
0+        GetColor = RGB(255, 128, 128)
0+    ElseIf r = 1 Then
0+        GetColor = RGB(255, 192, 192)
0+    ElseIf r = 0 Then
0+        GetColor = RGB(255, 224, 224)
0+    Else
0+        Call Err.Raise(1, "invalid relative")
0+    End If
0+End Function
0+
0+Function GetColors_2(rels As Scripting.Dictionary) As Scripting.Dictionary
0+    Dim c As Scripting.Dictionary
0+    Set c = New Scripting.Dictionary
0+    Dim i
0+    For Each i In rels.keys
0+        Call c.Add(i, GetColor(rels(i)))
0+    Next
0+    Set GetColors_2 = c
0+End Function
0+
0+Function GetColors(rowNum As Long, c As String) As Scripting.Dictionary
0+    Set GetColors = GetColors_2(GetRels(rowNum, c))
0+End Function
0+
0+Sub Main()
0+    Dim rowNum As Long
0+    Dim char1 As String
0+    rowNum = Excel.Selection.row
0+    char1 = Excel.Selection.Value
0+   
0+    ' Sort
0+    Dim v As Variant
0+    Dim sh1 As Excel.Worksheet
0+    Dim range1 As Excel.Range
0+    Set sh1 = Excel.Worksheets(1)
0+    Set range1 = sh1.Range("A1:C3")
0+    v = range1.Value
0+    Call Sort(v, 1, GetRels(rowNum, char1))
0+    range1.Value = v
0+   
0+    ' Coloring
0+    Dim c As Scripting.Dictionary
0+    Dim i As Excel.Range
0+    Dim j As Excel.Range
0+    Dim colNum As Long
0+    colNum = 1
0+    For Each i In range1.Rows(rowNum).Columns
0+        If i.Value = char1 Then
0+            Exit For
0+        End If
0+        colNum = colNum + 1
0+    Next
0+    For Each i In range1.Rows
0+        Set c = GetColors(i.row, i.Columns(colNum).Value)
0+        For Each j In i.Columns
0+            j.Interior.Color = c(j.Value)
0+        Next
0+    Next
0+End Sub
...
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
44
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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
--- Revision None
+++ Revision 346132313562
@@ -0,0 +1,115 @@
+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