جرب هذا الماكرو
Option Explicit
Sub give_text()
If ActiveSheet.Name <> "Sheet1" Then Exit Sub
Dim i%, k%, Colore: Colore = 35
Dim addrs As String
Dim st As String
Dim My_rg As Range: Set My_rg = [d3:d6]
Dim Formula_rg As Range: Set Formula_rg = [g9:g10]
Union(Formula_rg, My_rg).Interior.ColorIndex = xlNo
For k = 1 To Formula_rg.Rows.Count
Formula_rg.Cells(k).Interior.ColorIndex = Colore
st = Formula_rg.Cells(k).Formula
For i = 1 To My_rg.Rows.Count
addrs = My_rg.Cells(i).Address(0, 0)
If InStr(st, addrs) Then _
My_rg.Cells(i).Interior.ColorIndex = Colore
Next
Colore = Colore + 1
Next
End Sub