[vba]. read values in color only on vba.

[montecarlo2012]

Hi everyone.
How to read only the values with colors in a column and display this values in a row in another sheet, small example don't need xl2BB I think, so couple images can show my point.
this is what I have on sheet2

and this is the results I am expecting on sheet3

Please, Can anyone tell me how to do this.
thank you.

 

[DanteAmor]

On sheet 2, in column L, are there several colors or is it just one color?
Is the color normal or is it highlighted with conditional formatting?

 

[DanteAmor]

If you have RGB try the following:

Sub Macro7()
  With Sheets("Sheet2")
    .Range("L1", .Range("L" & Rows.Count).End(3)).AutoFilter 1, RGB(255, 192, 0), xlFilterCellColor
    .AutoFilter.Range.Offset(1).Copy
    Sheets("Sheet3").Range("B2").PasteSpecial xlPasteValues, , , True
    .ShowAllData
  End With
End Sub

 

[Ezguy4u]

Here is another version because, well you just can never have too many programs. Be sure to copy and past this one in a Module

Sub ColorMove()

Dim row1 As Integer
Dim col1 As Integer

Application.ScreenUpdating = False

col1 = 2
For row1 = 1 To 50

If Sheet2.Cells(row1, 12).Interior.ColorIndex > 1 Then

    Sheet2.Cells(row1, 12).Copy

    Sheet3.Cells(2, col1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
   
col1 = col1 + 1

End If

Next row1
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

 

[montecarlo2012]

Sorry I just open this forum web. Thanks DanteAmor, what do you mean by [ " If you have RGB "] not all version has this. about the color, yes is normal, and I tried and do not work.

 

[montecarlo2012]

Here is another version because, well you just can never have too many programs. Be sure to copy and past this one in a Module

Sub ColorMove()

Dim row1 As Integer
Dim col1 As Integer

Application.ScreenUpdating = False

col1 = 2
For row1 = 1 To 50

If Sheet2.Cells(row1, 12).Interior.ColorIndex > 1 Then

    Sheet2.Cells(row1, 12).Copy

    Sheet3.Cells(2, col1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
  
col1 = col1 + 1

End If

Next row1
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Thank you Sir, is working

 

[montecarlo2012]

Sorry about this, but I think I didn't mention is not just one column,
the columns to read are I, L, O, R, U, X, AA and for each one on sheet3 the display would be one after another
in case you don't mind, sorry.

 

[DanteAmor]

on sheet3 the display would be one after another

The next column of sheet2 in the next row of sheet3?

what do you mean by [ " If you have RGB "]

I mean the color of your cell.
Do you know the color number or RGB of your cell color?

Select a colored cell and run the following macro, it will show you in a message the RGB of the color of your cell.

Sub getRGBcolor()
  Dim r, g, b, m
  With ActiveCell.Interior
    r = .Color Mod 256
    g = .Color \ 256 Mod 256
    b = .Color \ 65536 Mod 256
    MsgBox "R=" & r & " G=" & g & " B=" & b
  End With
End Sub

 

[Ezguy4u]

Well this is a pretty big program but it should work. I hope I covered most of the criteria. If there is any other problems, let us know.

Sub ColorMove()

Dim row1 As Integer
Dim row2 As Integer
Dim col1 As Integer
Dim col2 As Integer

Application.ScreenUpdating = False

Worksheets("Sheet3").Activate
Range("A1").CurrentRegion.Select
Selection.Delete Shift:=xlToLeft
With Sheet3
.Range("A2") = "I"
.Range("A3") = "L"
.Range("A4") = "O"
.Range("A5") = "R"
.Range("A6") = "U"
.Range("A7") = "X"
.Range("A8") = "AA"
End With

col1 = 2
row2 = 2

For row1 = 1 To 50
If Sheet2.Cells(row1, "I").Interior.ColorIndex > 1 Then
    Sheet2.Cells(row1, "I").Copy
    Sheet3.Cells(row2, col1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
col1 = col1 + 1
End If

Next row1

col1 = 2
row2 = 3
For row1 = 1 To 50
If Sheet2.Cells(row1, "L").Interior.ColorIndex > 1 Then
    Sheet2.Cells(row1, "L").Copy
    Sheet3.Cells(row2, col1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
col1 = col1 + 1
End If

Next row1

col1 = 2
row2 = 4
For row1 = 1 To 50
If Sheet2.Cells(row1, "O").Interior.ColorIndex > 1 Then
    Sheet2.Cells(row1, "O").Copy
    Sheet3.Cells(row2, col1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
col1 = col1 + 1

End If

Next row1

col1 = 2
row2 = 5
For row1 = 1 To 50
If Sheet2.Cells(row1, "R").Interior.ColorIndex > 1 Then
    Sheet2.Cells(row1, "R").Copy
    Sheet3.Cells(row2, col1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
col1 = col1 + 1

End If

Next row1

col1 = 2
row2 = 6

For row1 = 1 To 50
If Sheet2.Cells(row1, "U").Interior.ColorIndex > 1 Then
    Sheet2.Cells(row1, "U").Copy
    Sheet3.Cells(row2, col1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
col1 = col1 + 1

End If

Next row1

col1 = 2
row2 = 7

For row1 = 1 To 50
If Sheet2.Cells(row1, "X").Interior.ColorIndex > 1 Then
    Sheet2.Cells(row1, "X").Copy
    Sheet3.Cells(row2, col1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
col1 = col1 + 1

End If

Next row1

col1 = 2
row2 = 8

For row1 = 1 To 50
If Sheet2.Cells(row1, "AA").Interior.ColorIndex > 1 Then
    Sheet2.Cells(row1, "AA").Copy
    Sheet3.Cells(row2, col1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
col1 = col1 + 1
End If

Next row1

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

 

[montecarlo2012]

Excellent DanteAmor. Thank you for your help.