Move Value if Cell formated as red

[thunder_anger]

Dear all

i have here two worksheets one named HostValues and another one named RealValues

when i check the hostvalues sheet i formate some cells with red
the required is whenever i color a cell with red it moves the value to the other sheet
i tried to write a code but didn't work

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MystRng As Range
Dim dCell As Range
Set MystRng = Sheets("HostValues").Range("D3:D1100")
LR = Sheets("RealValues").Range("A", Rows.Count).End(xlUp).Row
For Each dCell In MystRng
If dCell.Interior.ColorIndex = 3 Then
dCell.Copy
*****
***** ' i stopped here because i tried so much things and did not work
End Sub

any help

 

[VoG]

Colouring a cell will not trigger the Worksheet_Change event. You would need to code this as a regular macro.

 

[thunder_anger]

Did not know this be4 thanks any way but still can not figure it out

is there a code that would do what i want??
i will color all the values that i need and then move them

 

[thunder_anger]

Hi all

I wanted to share this solution with you

Jaafar Tribak did it for me

Cell coloring will trigger a macro

just put this in a class module

Option Explicit

Private WithEvents cmb As Office.CommandBars

Private bCancel As Boolean
Private bAllCellsCounted As Boolean
Private vCellCurColor() As Variant
Private vCellPrevColor() As Variant
Private sCellAddrss() As String
Private sVisbRngAddr As String
Private i As Long
Private oSh As Worksheet
Private oCell As Range

Public Sub ApplyToSheet(Sh As Worksheet)

    Set oSh = Sh
    
End Sub

Public Sub StartWatching()

    Set cmb = Application.CommandBars
    
End Sub

Private Sub Class_Initialize()

    bAllCellsCounted = False
    
End Sub


Private Sub cmb_OnUpdate()

    If Not ActiveSheet Is oSh Then Exit Sub
    bCancel = False
    i = -1
VisibleRngChanged:
    If sVisbRngAddr <> ActiveWindow.VisibleRange.Address _
        And sVisbRngAddr <> "" Then
        Erase sCellAddrss
        Erase vCellCurColor
        Erase vCellPrevColor
        sVisbRngAddr = ""
        bAllCellsCounted = False
        GoTo VisibleRngChanged
    End If
    On Error Resume Next
        For Each oCell In ActiveWindow.VisibleRange.Cells
            ReDim Preserve sCellAddrss(i + 1)
            ReDim Preserve vCellCurColor(i + 1)
            sCellAddrss(i + 1) = oCell.Address
            vCellCurColor(i + 1) = oCell.Interior.Color
            If vCellPrevColor(i + 1) <> vCellCurColor(i + 1) Then
                If bAllCellsCounted = True Then
                    oCell.Interior.Color = vCellPrevColor(i + 1)
                    CallByName oSh, _
                    "CellColorChanged", VbMethod, oCell, _
                    oCell.Interior.Color, bCancel
                    If Not bCancel Then
                        oCell.Interior.Color = vCellCurColor(i + 1)
                        vCellPrevColor(i + 1) = vCellCurColor(i + 1)
                    Else
                        oCell.Interior.Color = vCellPrevColor(i + 1)
                        vCellCurColor(i + 1) = vCellPrevColor(i + 1)
                    End If
                    bCancel = False
                End If
            End If
                i = i + 1
            If i + 1 >= ActiveWindow.VisibleRange.Cells.Count Then
                bAllCellsCounted = True
                ReDim Preserve vCellPrevColor(UBound(vCellCurColor))
                vCellPrevColor = vCellCurColor
            End If
            vCellPrevColor(i + 1) = vCellCurColor(i + 1)
        Next
    On Error GoTo 0
        sVisbRngAddr = ActiveWindow.VisibleRange.Address

End Sub

and put this in This Workbook Module

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call Sheet1.StopWatching_Click
End Sub

Private Sub Workbook_Open()
    Call Sheet1.StartWatching_Click
End Sub

and put this in sheet 1 module

Option Explicit

Private oCellColorMonitor As C_CellColorChange

Public Sub CellColorChanged(Cell As Range, Color As Variant, Cancel As Boolean)
    
    Const MSG1 As String = "You are trying to change the Color of Range : "
    Const MSG2 As String = "Do you want to go ahead ?"
    
    If MsgBox(MSG1 & Cell.Address & vbNewLine & MSG2, vbQuestion + vbYesNo) _
    = vbNo Then
        Cancel = True
    End If

End Sub


Public Sub StartWatching_Click()

    Set oCellColorMonitor = New C_CellColorChange
    oCellColorMonitor.ApplyToSheet Me
    oCellColorMonitor.StartWatching
    
End Sub

Public Sub StopWatching_Click()

    Set oCellColorMonitor = Nothing
    
End Sub

 

[thunder_anger]

and that is the code i use

in the sheet module to apply what i wanted

Public Sub CellColorChanged(Cell As Range, Color As Variant, Cancel As Boolean)

   If Union(Cell, Range("A1:A8563")).Address = Range("A1:A8563").Address Then
        If Color = vbRed Then
            With Sheets("Real Data")
               Cell.Copy .Cells(Cell.Row, 3)
                'Cell.Copy .Cells(Cell.Row - 5, 3)
               .Cells(Cell.Row, 3).Interior.Color = xlNone
                '.Cells(Cell.Row - 5, 3).Interior.Color = vbRed
            End With
        End If
    End If

End Sub

 

[thunder_anger]

is not that good????

 

[VoG]

Anything that Jaafar does is brilliant and thanks for sharing.