Sort Color delete lock Revision 346132313562 (Thu Dec 13 2012 at 03:30) - Diff Link to this snippet: https://friendpaste.com/2HcrMkLVj8VbUfTrZXDCy2 Embed: manni perldoc borland colorful default murphy trac fruity autumn bw emacs pastie friendly Show line numbers Wrap lines 1234567891011121314151617181920212223242526272829303132333435363738394041424344245464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919219394195969798991001011021031041051061071081091101111121131141155Sub 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) NextEnd SubSub 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 NextEnd SubFunction GetSheet(rowNum As Long) As Excel.Worksheet Set GetSheet = Excel.Worksheets(rowNum + 1)End FunctionFunction 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 = rEnd FunctionFunction GetRels(rowNum As Long, c As String) As Scripting.Dictionary Set GetRels = GetRels_2(GetSheet(rowNum), c)End FunctionFunction 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 IfEnd FunctionFunction 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 = cEnd FunctionFunction GetColors(rowNum As Long, c As String) As Scripting.Dictionary Set GetColors = GetColors_2(GetRels(rowNum, c))End FunctionSub 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 NextEnd Sub