requesting help on restructuring code to work on extracting data w. int color red

[estatefinds]

Function GetColorText(pRange As Range) As String 'Updateby20141105
Dim xOut As String
Dim xValue As String
Dim i As Long
xValue = pRange.Text


For i = 1 To VBA.Len(xValue)


If pRange.Characters(i, 1).Font.Color = vbRed Then
xOut = xOut & VBA.Mid(xValue, i, 1)
End If


Next


GetColorText = xOut
End Function




I attached a file that shows data that is colored interior red and other data no interior color. I need the existing code to work with interior color of cell instead of the Font color.

For eample I want to be able to run macro that would remove the data colored in red from the range A22 to E22 and move them from rows to Column, column J starting at row 22; leaving the remaining uncolored data alone.

Any help on this is greatly appreciated.
Sincerely Dennis

[estatefinds]

I'M trying to accomplish geting macro to return all the values colored red into column G.





Sub Test2(Target As Range) Dim R As Range, arr, a
Dim cel As Variant

Set R = Range("A:E").SpecialCells(2)
For Each cel In R
If cel.Interior.ColorIndex = 6 Then
cel.Interior.ColorIndex = xlNone
End If
Next

Set R = Nothing

Set R = Range("A:E").SpecialCells(2)
For Each cel In R
If cel.Interior.ColorIndex = 6 Then
cel.Interior.ColorIndex = xlNone
End If
Next

Set al = CreateObject("system.collections.arraylist")




arr = Split(Target, "-") ' THE SPLIT NEEDS TO BE REMOVED AS IT DOESNT APPLY TO MY CURRENT DATA

For Each a In arr
Call DoFind(R, a)
Next

al.Sort
Dim k As Long


k = WorksheetFunction.Max(5, Cells(Rows.Count, "G").End(xlUp).Row + 1)
Cells(k, "G").Value = Join(al.toarray, "-")

End Sub

[estatefinds]

the color index number for the code should be 3

[jolivanes]

Like this?

Sub AAAAA()
Dim fr As Long, lr As Long, lc As Long, c As Range
fr = IIf(Len(Range("A1")) <> 0, 1, Range("A1").End(xlDown).Row)
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(fr, 1).End(xlToRight).Column


For Each c In Range(Cells(fr, 1), Cells(lr, lc)).SpecialCells(2)
If c.Interior.ColorIndex = 3 Then Cells(Rows.Count, 10).End(xlUp).Offset(1) = c.Value
Next c
End Sub

Or if you want to go Column by Column

Sub AAAAB()
Dim fr As Long, lr As Long, lc As Long, i As Long, ii As Long
fr = IIf(Len(Range("A1")) <> 0, 1, Range("A1").End(xlDown).Row)
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(fr, 1).End(xlToRight).Column


For i = 1 To lc
For ii = fr To lr
If Cells(ii, i).Interior.ColorIndex = 3 Then Cells(Rows.Count, 10).End(xlUp).Offset(1) = Cells(ii, 1).Value
Next ii
Next i
End Sub

[estatefinds]

Awsome!!! thank you very much!!!!:clap: