Is this possible?

[finaddict]

I just copied and pasted the code into the white box after right clicking the sheet tab and veiwing the code. It didn't do anything. But I'm pretty sure I didn't do something right.

Thanks,
Steve

[HOTPEPPER]

With your worksheet open, press ALT-F11, this will open the VBA Editor.

Select View...Project Explorer

On the project explorer Right click on the
Microsoft Excel Objects Folder for the current sheet.
Select Insert...Module

Just paste the code to this new module and close the explorer (ALT-Q)

Press ALT-F8 to bring up the macro window
Since copycolor is the name of this macro, select copycolor and hit Run.

When you save the worksheet, this code will be saved with it.

[finaddict]

Still didn't work. Do I paste the code in sheet1 or sheet2?

Thanks,
Steve

[finaddict]

Hey Hot Pepper. I finally got it to work. Thanks for your help and patience.

Thanks,
Steve

[finaddict]

Well, I thought I did. If I change the numbers in sheet1 then it don't work.

Thanks,
Steve

[HOTPEPPER]

Are you re-running the macro after you change the numbers?

Hit Alt-F8 again, select the copycolor macro and hit RUN

[finaddict]

Ok. I did have to hit alt-F8 and it did work. The problem I have now with it is that if there is a break in numbers it will not list the numbers after the break. For example: sheet1 column A has cells 1,2,3,5,9,12....which have a colored number in them. On sheet2 in cell A1 it will only list 1,2,3 and no other numbers. And if the column doesn't start in the first cell it doesn't list any numbers that are after that in other cells.

Thanks,
Steve

[HOTPEPPER]

I assume when you say there is a break in the numbers in the first column, you mean there is an empty cell between them, because the macro doesn't care what numbers are in them.
The macro is currently looking for the first blank cell it comes across in the columns to determine when it is finished, I will take a look at it later to see if I can come up with a better solution.

[HOTPEPPER]

OK, replace the old copycolor macro with this one. Please let me know how it goes:

Sub copycolor()
Dim combine As String
Dim colorarray(65536) As Long
Dim valuearray(65536) As String
w = 1
r = 0

Worksheets("Sheet2").Activate
Worksheets("Sheet2").Range("A1:IV65536") = ""

For x = 1 To 256

Worksheets("Sheet1").Activate
y = 1
Myrange = Worksheets("Sheet1").Columns(x)
q = Application.WorksheetFunction.Sum(Myrange)
While r <> q
d = Str$(Cells(y, x))
If d <> " 0" Then
c = c + 1
valuearray(c) = Str$(Cells(y, x))
colorarray(c) = Cells(y, x).Font.Color
combine = combine + valuearray(c) + ", "
End If
r = r + Cells(y, x)
y = y + 1
Wend

If combine = "" And r = q Then Exit Sub
combine = Left(combine, Len(combine) - 2)

e = 1
y = c
Worksheets("Sheet2").Activate
With Worksheets("Sheet2").Cells(w, 1)
.Value = combine
For u = 1 To y
z = Len(valuearray(u)) + 2
.Characters(e, z).Font.Color = colorarray(u)
e = e + z
Next u
End With
w = w + 1
combine = ""
r = 0
q = 0
c = 0
Next x
End Sub

[finaddict]

Like a FREAKIN' charm!!!!!!!!!!!! Worked beautifully!!!!!!!!! Man! How can I ever repay you? Can't thank you enough!