تحديد نصوص في خلية بدوائر بناء على معطيات من صفحة اخرى

[mohanad2025]

السلام عليكم ممكن كود او معادلة تحديد نصوص بدوائر  يعتمد على معطيات في صفحة اخرى ... الشرح داخل المرفق .. جزاكم الله خيرا

فورمة.xlsb

[محمد هشام.]

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

يمكنك تنفيذ ذلك باستخدام الأكواد ولكن أعتقد أنه سيكون من الضروري أولا تنظيم البيانات في ورقة العمل  Menuf بشكل جيد ومن الأفضل كذلك فك الخلايا المدمجة لضمان الحصول على نتائج دقيقة  ووضع الدوائر حول القيم المطلوبة بشكل صحيح

إذا كان هذا يناسبك فالكود التالي ربما يساعدك في تنفيذ طلبك

' تحديد عرض الدائرة
Const xWidth As Single = 40
' تحديد طول الدائرة
Const xlength As Single = 55

Sub AddDrawCircles()
    Dim dest As Worksheet, CrWS As Worksheet
    Dim Search As String, dataValue As String
    Dim ColArr As Long, lastRow As Long, i As Long, col As Long
    Dim cell As Range, OnRng As Range, shp As Shape, lastCol As Long
    Dim n As Boolean, a() As String, ky As Variant, r() As String

    On Error GoTo SupApp

    Set CrWS = Sheets("main sheet"): Set dest = Sheets("MenuF")
    Search = Trim(dest.[B1].Value)
    If Search = "" Then MsgBox "يرجى إدخال قيمة البحث", vbExclamation: Exit Sub

    SetApp False

    lastRow = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow
        If Trim(CrWS.Cells(i, 1).Value) = Search Then ColArr = i: n = True: Exit For
    Next i
     If Not n Then MsgBox "قيمة البحث غير موجودة على قاعدة البيانات", vbExclamation, "إنتبـــاه": GoTo CleanUp
    

    For Each shp In dest.Shapes: If Left(shp.Name, 4) = "Oval" Then shp.Delete
    Next shp

    lastCol = CrWS.Cells(ColArr, Columns.Count).End(xlToLeft).Column
    ReDim a(1 To lastCol - 1)
    For col = 2 To lastCol: a(col - 1) = Trim(CrWS.Cells(ColArr, col).Value): Next col

    Set OnRng = dest.Range("A3:I7")
    For col = 1 To 6
        dataValue = a(col)
        If dataValue <> "" Then
            For Each cell In OnRng
                If cell.Value <> "" Then
                    r = Split(Replace(cell.Value, "،", ","), ",")
                    For Each ky In r
                        If CompareValues(tmp(ky), tmp(dataValue)) Then DrawCircle cell: Exit For
                    Next ky
                End If
            Next cell
        End If
    Next col

CleanUp:
    SetApp True
    Exit Sub

SupApp:
    Resume ExitSub
ExitSub:
End Sub
'"""""""""""""""""""""""""""""
Private Function tmp(ByVal txt As String) As String
    tmp = Replace(Replace(Trim(txt), "  ", " "), "ال", "")
End Function
'""""""""""""""""""""""""""""
Private Function CompareValues(value1 As String, value2 As String) As Boolean
    CompareValues = (InStr(1, value1, value2, vbTextCompare) > 0 Or InStr(1, value2, value1, vbTextCompare) > 0)
End Function
'"""""""""""""""""""""""""""""""""""""""""
Private Sub DrawCircle(cell As Range)
    With cell.Worksheet.Shapes.AddShape(msoShapeOval, _
        cell.Left + (cell.Width - xlength) / 2, _
        cell.Top + (cell.Height - xWidth) / 2, _
        xlength, xWidth)
        .Fill.Visible = msoFalse
        .Line.ForeColor.RGB = RGB(255, 0, 0)
        .Line.Weight = 1.5
        .Name = "Oval_" & cell.Address(False, False)
    End With
End Sub
'"""""""""""""""""""""""""""
Private Sub SetApp(ByVal enable As Boolean)
    On Error Resume Next
    Application.ScreenUpdating = enable
    Application.EnableEvents = enable
    Application.DisplayAlerts = enable
    Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
End Sub

وفي حدث ورقة Menuf 

Option Explicit 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B1")) Is Nothing Then
        AddDrawCircles
    End If
End Sub

 

فورمة - V2.xlsb

[Abaas]

عمل جميل من الاخ محمد هشام ... جزاك الله كل خير لجهودك في مساعده الاخوة في هذا  المنتدى الكبير ..

كيف يكون الكود بدل ان يكون التحديد بدوائر ان يكون التحديد ب cheekbox  لكل من التفاصيل في المصنف ..وفقنا الله واياكم لكل خير

فورمةv3.xlsb

تم تعديل منذ 1 ساعه بواسطه Abaas