طلب مساعده في في البحث في بيانات عمود

[Hamedelbhrawy]

السلام عليكم ورحمة الله وبركاته 

محتاج دالة تأخد الرقم ال في خلية القيد و تدرو عليه في عمود ملاحظات  ولو موجود تلون الخليه 

مع العلم ان الخليه في عمود ملاحظات مكتوب فيها اكثر من رقم 

هل ممكن ؟

 

test (1).xlsx

[سليم حاصبيا]

جرب هذا الماكرو

Option Explicit
Sub TALWEEN()
Rem ====>> Created by Salim Hasbaya 6/7/2019
Application.ScreenUpdating = False
Dim My_RGG As Range
Dim My_RGH As Range
Dim g%, h%
 Dim r%, r1, s_rg As Range
Set My_RGG = Range("G3:G" & Cells(Rows.Count, 1).End(3).Row)
Set My_RGH = Range("H3:H" & Cells(Rows.Count, 1).End(3).Row)
Union(My_RGH, My_RGG).Interior.ColorIndex = xlNone
For g = 1 To My_RGG.Rows.Count
          If My_RGG.Cells(g) = vbNullString Then GoTo Next_g
      Set s_rg = My_RGH.Find(My_RGG.Cells(g), lookat:=2)
    If s_rg Is Nothing Then
    GoTo Next_g
    End If
    My_RGG.Cells(g).Interior.ColorIndex = 6
     r = s_rg.Row: r1 = r
     My_RGH.Cells(r - 2).Interior.ColorIndex = 6
     Do
         Set s_rg = My_RGH.FindNext(s_rg)
         My_RGH.Cells(r - 2).Interior.ColorIndex = 6
        r = s_rg.Row
        If r = r1 Then Exit Do
     Loop
Next_g:
    Next
Set My_RGG = Nothing
Set My_RGH = Nothing
Set s_rg = Nothing
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

test (1)salim.xlsm