sort cells by color ?Macro?

[JVLennox]

Hi everybody!

I have a pretty messed up but COLORED table.
Now I would like to put the CELLS WITHIN A ROW into the right order.

Since each cell in a row has a specific color it's no problem - thats
what I thought...!!! :-(

Here's the scheme:
Each row has 3-6 cells, all in a different color.
Now, I would like to have these cells in a specific order: white,
yellow, green, blue, black, red - so that I end up having in each
column only one color.
BUT in some rows some of those colors might be missing, that's why I
actually don´t think a sorting function would really help. If a color
is missing, then their should just be a blank in the colored column.

Here's an example-file: http://www.herber.de/bbs/user/31944.xls

I guess, it must be something like a macro that doesn't sort, but
COPIES the colored cells of a row into the specified column [each color
goes to an according column]
so that it ends up with a column of red cells, a column of white cells,
and so on...

Here's an example-file: http://www.herber.de/bbs/user/31944.xls


I am not good with VBA, I tried to record some macros and manipulate
them, but I never reached anything usefull.

Can anybody give me some hints??????

THANKS SO MUCH FOR TAKING THE TIME!!!

 

[Peter Rooney]

Have you tried Jim Cone's Special Sort add-in?
It can sort by background colour and font colour amongst many others - but,
I think he likes to send it out himself.
He's on (e-mail address removed) (at least that's what it says on the add-in help
screen, so I hope he doesn't mind me telling you)

Regards

Pete

 

[Ken Johnson]

Hi JVLennox,
this worked for me, but where did that extra green cell come from?

Public Sub ColorSort()
Dim iLastRow As Long
Dim iFirstRow As Long
Dim iLastColumn As Long
Dim iFirstColumn As Long
Dim iRowCounter As Long
Dim iColumnCounter As Integer
Dim rgColorRange As Range
Dim iWhiteColumns1 As Integer
Dim iYellowColumns1 As Integer
Dim iGreenColumns1 As Integer
Dim iBlueColumns1 As Integer
Dim iBrownColumns1 As Integer
Dim iRedColumns1 As Integer
Dim iWhiteColumns2 As Integer
Dim iYellowColumns2 As Integer
Dim iGreenColumns2 As Integer
Dim iBlueColumns2 As Integer
Dim iBrownColumns2 As Integer
Dim iRedColumns2 As Integer
Dim iWhitePaste As Integer
Dim iYellowPaste As Integer
Dim iGreenPaste As Integer
Dim iBluePaste As Integer
Dim iBrownPaste As Integer
Dim iRedPaste As Integer
Dim iFinalNumColumns As Integer
Dim iLastWhiteCol As Integer
Dim iLastYellowCol As Integer
Dim iLastGreenCol As Integer
Dim iLastBlueCol As Integer
Dim iLastBrownCol As Integer
Dim iLastRedCol As Integer

Set rgColorRange = Application.InputBox( _
Prompt:="Please select the colored cells", _
Default:=Selection.Address, _
Type:=8)
iFirstRow = rgColorRange.Row
iLastRow = iFirstRow + rgColorRange.Rows.Count - 1
iFirstColumn = rgColorRange.Column
iLastColumn = iFirstColumn + rgColorRange.Columns.Count - 1
For iRowCounter = iFirstRow To iLastRow
iWhiteColumns1 = 0: iYellowColumns1 = 0: iGreenColumns1 = 0
iBlueColumns1 = 0: iBrownColumns1 = 0: iRedColumns1 = 0
For iColumnCounter = iFirstColumn To iLastColumn
Select Case Cells(iRowCounter, iColumnCounter) _
..Interior.ColorIndex
Case -4142
If Cells(iRowCounter, iColumnCounter).Value <> "" Then
iWhiteColumns1 = iWhiteColumns1 + 1
End If
Case 6
iYellowColumns1 = iYellowColumns1 + 1
Case 4
iGreenColumns1 = iGreenColumns1 + 1
Case 5
iBlueColumns1 = iBlueColumns1 + 1
Case 53
iBrownColumns1 = iBrownColumns1 + 1
Case 3
iRedColumns1 = iRedColumns1 + 1
End Select
If iWhiteColumns1 > iWhiteColumns2 Then
Let iWhiteColumns2 = iWhiteColumns1
End If
If iYellowColumns1 > iYellowColumns2 Then
Let iYellowColumns2 = iYellowColumns1
End If
If iGreenColumns1 > iGreenColumns2 Then
Let iGreenColumns2 = iGreenColumns1
End If
If iBlueColumns1 > iBlueColumns2 Then
Let iBlueColumns2 = iBlueColumns1
End If
If iBrownColumns1 > iBrownColumns2 Then
Let iBrownColumns2 = iBrownColumns1
End If
If iRedColumns1 > iRedColumns2 Then
Let iRedColumns2 = iRedColumns1
End If
Next
Next
iLastWhiteCol = iFirstColumn + iWhiteColumns2
iLastYellowCol = iLastWhiteCol + iYellowColumns2
iLastGreenCol = iLastYellowCol + iGreenColumns2
iLastBlueCol = iLastGreenCol + iBlueColumns2
iLastBrownCol = iLastBlueCol + iBrownColumns2
iLastRedCol = iLastBrownCol + iRedColumns2
iFinalNumColumns = iLastRedCol _
- iFirstColumn + 1
For iRowCounter = iLastRow To iFirstRow Step -1
With Range(Cells(iRowCounter, 1), _
Cells(iRowCounter, iLastColumn))
.Insert Shift:=xlDown
.Offset(-1, 0).Clear
End With
iWhitePaste = 0: iYellowPaste = 0: iGreenPaste = 0
iBluePaste = 0: iBrownPaste = 0: iRedPaste = 0
For iColumnCounter = iFirstColumn To iLastColumn
Select Case Cells(iRowCounter + 1, iColumnCounter) _
..Interior.ColorIndex
Case -4142
If Cells(iRowCounter + 1, iColumnCounter).Value <> "" Then
Cells(iRowCounter + 1, iColumnCounter) _
..Copy Cells(iRowCounter, iFirstColumn + iWhitePaste)
iWhitePaste = iWhitePaste + 1
End If
Case 6
Cells(iRowCounter + 1, iColumnCounter) _
..Copy Cells(iRowCounter, iWhiteColumns2 + 1 + iYellowPaste)
iYellowPaste = iYellowPaste + 1
Case 4
Cells(iRowCounter + 1, iColumnCounter) _
..Copy Cells(iRowCounter, iWhiteColumns2 + iYellowColumns2 _
+ 1 + iGreenPaste)
iGreenPaste = iGreenPaste + 1
Case 5
Cells(iRowCounter + 1, iColumnCounter) _
..Copy Cells(iRowCounter, iWhiteColumns2 + iYellowColumns2 _
+ iGreenColumns2 + 1 + iBluePaste)
iBluePaste = iBluePaste + 1
Case 53
Cells(iRowCounter + 1, iColumnCounter) _
..Copy Cells(iRowCounter, iWhiteColumns2 + iYellowColumns2 _
+ iGreenColumns2 + iBlueColumns2 + 1 + iBrownPaste)
iBrownPaste = iBrownPaste + 1
Case 3
Cells(iRowCounter + 1, iColumnCounter) _
..Copy Cells(iRowCounter, iWhiteColumns2 + iYellowColumns2 _
+ iGreenColumns2 + iBlueColumns2 + iBrownColumns2 + 1 _
+ iRedPaste)
iRedPaste = iRedPaste + 1
End Select
Next
Range(Cells(iRowCounter + 1, 1), _
Cells(iRowCounter + 1, iLastColumn)).Delete Shift:=xlUp
Next
Range(Cells(iFirstRow, iFirstColumn), Cells(iFirstRow, _
iLastColumn + iFinalNumColumns - 1)).Insert Shift:=xlDown
Range(Cells(iFirstRow, iFirstColumn), _
Cells(iFirstRow, iLastWhiteCol - 1)).Value = "WEISS"
Range(Cells(iFirstRow, iLastWhiteCol), _
Cells(iFirstRow, iLastYellowCol - 1)).Value = "GELB"
Range(Cells(iFirstRow, iLastYellowCol), _
Cells(iFirstRow, iLastGreenCol - 1)).Value = "GRÜN"
Range(Cells(iFirstRow, iLastGreenCol), _
Cells(iFirstRow, iLastBlueCol - 1)).Value = "BLAU"
Range(Cells(iFirstRow, iLastBlueCol), _
Cells(iFirstRow, iLastBrownCol - 1)).Value = "BRAUN"
Range(Cells(iFirstRow, iLastBrownCol), _
Cells(iFirstRow, iLastRedCol - 1)).Value = "ROT"
Range(Cells(iFirstRow, iFirstColumn), Cells(iFirstRow, _
iLastRedCol)).Font.Bold = True
End Sub

Ken Johnson

 

[JVLennox]

Hey Ken, thanks a lot!

BUT I always get a Syntax error in the Editor for the "3D" in you
code...???
Where does that come from?

Thanks so much!

@ Pete: I'll try sending him an email

 

[Ken Johnson]

Hi JV,
What is the "3D"?
Which line produces the error?
I copied the code from above then pasted it into a new workbook and it
worked fine.
Ken Johnson

 

[Tim Williams]

I think the added "3D" is a problem with some web-based newsgroup hosts
(such as the one JV is using).

Tim

 

[Ken Johnson]

Hi Tim
thanks for that.
I wonder, is there is a simple solution.
Would emailing the code an option?
Ken Johnson

 

[Tim Williams]

I guess so. But many posters don't include a valid e-mail.

Tim

 

[Ken Johnson]

Thanks again Tim.
JV's probably better served by Jim Cone's addin, which I'm sure would
better tested than my verbose code, so I'll just wait and see.
Ken Johnson