Sub ColorAndCopy()
Dim Sh As Worksheet: Dim MyAdd As String
Dim Rng As Range, sRng As Range, cRng As Range
Dim jJ As Long, eRw As Long
1 ' Add Font Color Or Interior Color '
Set Sh = Sheets("SP")
Set Rng = Sh.Range(Sh.[c10], Sh.[c65500].End(xlUp))
Sheets("PM").Select: eRw = [d65500].End(xlUp).Row
For jJ = 2 To eRw
With Cells(jJ, "G")
If .Value <> "" Then
Set sRng = Rng.Find(.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
sRng.Font.ColorIndex = 3
.Interior.ColorIndex = 35
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End If
End With
Next jJ
2 ' Copy From None Color "SP" '
Sheets("KQ").Select: Cells.Clear
[a1].Resize(, 9).Value = Sheets("PM").[a1].Resize(, 9).Value
eRw = Sh.[A65500].End(xlUp).Row
Set Rng = Sh.Range(Sh.[c11], Sh.Cells(eRw, "C"))
For Each sRng In Rng
With sRng
If .Value <> "" And .Font.ColorIndex <> 3 Then
Set cRng = Cells(65500, "C").End(xlUp)
cRng.Offset(1).Value = .Offset(, -1).Value
cRng.Offset(1, 5).Value = .Value
cRng.Offset(1, 6).Value = .Offset(, 2).Value
End If
End With
Next sRng
3 ' Copy From "PM" '
Set Rng = Nothing
Set Sh = Sheets("PM"): eRw = Sh.[d65500].End(xlUp).Row
For jJ = 2 To eRw
With Sh.Cells(jJ, "G")
If .Value <> "" And .Interior.ColorIndex <> 35 Then
If Rng Is Nothing Then
Set Rng = .Offset(, -6).Resize(, 9)
Else
Set Rng = Union(Rng, .Offset(, -6).Resize(, 9))
End If
End If
End With
Next jJ
Rng.Copy Destination:=[c65500].End(xlUp).Offset(1, -2)
End Sub
