Grouping / sorting row - help please!!

[jacatra]

Hello all,

I need another help with this issue -- I'm writing a VB/Excel macro code to group/sort a list of items based on the colour of the item:

Column A contains the name of the item
Column B contains the share that the item has overall
Column C contains the deviation of the item's share against the average

The items in Column C are colour coded, i.e. red if the deviation is below a set level, and blue, if the deviation is above the set level, and black if it is as expected. The colouring is already taken care of.

Now, the issue is, I need to group items based on Column C, i.e. based on the colours of the items. This is the code that I've worked on so far - but it doesn't work! It checks the colour of the cell two-below and then swap it with the one below if its colour matches. It should loop until there are no more rows to swap. Can somebody enlighten me please?

   swapCount = 1
   Do Until swapCount = 0
      swapCount = 0
      endflag = False
      CompareRow = 3
      y = 4
      z = 5
     
      Do While Not endflag
         If (Cells(CompareRow, 3).Font.Color = Cells(z, 3).Font.Color) And (Cells(y, 3).Font.Color <> Cells(CompareRow, 3).Font.Color) Then
            Range(Cells(z, 1), Cells(z, 3)).Copy
            Range(Cells((LastRow + y + 1), 1), Cells((LastRow + y + 1), 3)).Select
            ActiveSheet.Paste
            Range(Cells(y, 1), Cells(y, 3)).Copy
            Range(Cells((LastRow + z + 1), 1), Cells((LastRow + z + 1), 3)).Select
            ActiveSheet.Paste
            CompareRow = CompareRow + 2
            swapCount = 1
         Else
            Range(Cells((CompareRow), 1), Cells((CompareRow), 3)).Copy
            Range(Cells((LastRow + CompareRow + 1), 1), Cells((LastRow + CompareRow + 1), 3)).Select
            ActiveSheet.Paste
            Range(Cells(y, 1), Cells(y, 3)).Copy
            Range(Cells((LastRow + y + 1), 1), Cells((LastRow + y + 1), 3)).Select
            ActiveSheet.Paste
            swapCount = 0
         End If
      
         If z < LastRow Then
            CompareRow = CompareRow + 1
            y = CompareRow + 1
            z = CompareRow + 2
         Else
            endflag = True
         End If
      Loop
      
      If swapCount = 0 Then
         Range(Cells((LastRow + 5), 1), Cells((LastRow + z + 1), 3)).Cut
         Range(Cells(4, 1), Cells(LastRow, 3)).Select
         ActiveSheet.Paste
      End If
   
   Loop

There's actually a bigger challenge for me, as the loop needs to traverse to the next columns and swap the row, only if there are two or more adjacent cells with the same colour horizontally, whilst maintaining the order of the items row-wise and column-wise. i.e. if the item is ordered as 1-5-3-2-4 after the grouping, the columns need to be reordered as 1-5-3-2-4, which fulfils the rule as stated above (i.e. swap the row, only if there are two adjacent horizontal cells with the same colour, with minor distruptions vertically to the first column and so forth). It's basically a self-referencing matrix, comparing each item on the list against themselves.

If somebody can help me with the first challenge that will be much appreciated - the second one seems so insurmountable at the moment.

Thank you!!!!!