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

[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

تم تعديل الإثنين at 17:42 بواسطه Abaas

[محمد هشام.]

8 ساعات مضت, Abaas said:

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

من المفروض أولا كما سبق الدكر محاولة إلغاء دمج الخلايا لضمان أن الكود يتعامل مع كل خلية على حدة وحصولك على نتائج صحيحة  

جرب هدا هل يناسيك 

Option Explicit
Public Sub Add_CheckBoxes()
    Dim tbl As Long, cb As OLEObject, OnRng As Range, ky As Variant
    Dim dataArray() As String, Search As String, n As Boolean
    Dim i As Long, lastRow As Long, col As Long, lastCol As Long
    Dim kys() As String
    
    Dim CrWS As Worksheet: Set CrWS = Sheets("MenuF")
    Dim dest As Worksheet: Set dest = Sheets("main sheet")

    Search = Trim(CrWS.Range("B1").Value)
    If Search = "" Then: MsgBox "يرجى إدخال قيمة البحث", vbExclamation: Exit Sub

    lastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row
    n = False
    For i = 2 To lastRow
        If Trim(dest.Cells(i, 1).Value) = Search Then
            tbl = i
            n = True
            Exit For
        End If
    Next i

    If Not n Then: MsgBox "قيمة البحث غير موجودة على قاعدة البيانات", vbExclamation: Exit Sub

    lastCol = dest.Cells(tbl, Columns.Count).End(xlToLeft).Column
    ReDim dataArray(1 To lastCol - 1)
    For col = 2 To lastCol
        dataArray(col - 1) = Trim(dest.Cells(tbl, col).Value)
    Next col

    For Each cb In CrWS.OLEObjects
        If TypeName(cb.Object) = "CheckBox" Then cb.Object.Value = False
    Next cb
    For Each OnRng In CrWS.Range("A3:I7")
        If OnRng.Value <> "" Then
            kys = Split(Replace(OnRng.Value, "،", ","), ",")
            For Each ky In kys
                For i = LBound(dataArray) To UBound(dataArray)
                    If CompareValues(tmp(dataArray(i)), tmp(ky)) Then
                        For Each cb In CrWS.OLEObjects
                            If TypeName(cb.Object) = "CheckBox" Then
                                If cb.TopLeftCell.Address = OnRng.Address Then
                                    cb.Object.Value = True
                                    Exit For
                                End If
                            End If
                        Next cb
                    End If
                Next i
            Next ky
        End If
    Next OnRng
End Sub

Private Function tmp(ByVal txt As String) As String
    tmp = Replace(Replace(Trim(txt), "  ", " "), "ال", "")
End Function

Private Function CompareValues(val1 As String, val2 As String) As Boolean
    CompareValues = (InStr(1, val1, val2, vbTextCompare) > 0 Or InStr(1, val2, val1, vbTextCompare) > 0)
End Function

 لتلوين القيم 

CrWS.Range("A3:I7").Font.Color = vbBlack

    For Each OnRng In CrWS.Range("A3:I7")
        If OnRng.Value <> "" Then
            kys = Split(Replace(OnRng.Value, "?", ","), ",")
            For Each ky In kys
                For i = LBound(dataArray) To UBound(dataArray)
                    If CompareValues(tmp(dataArray(i)), tmp(ky)) Then
                        For Each cb In CrWS.OLEObjects
                            If TypeName(cb.Object) = "CheckBox" Then
                                If cb.TopLeftCell.Address = OnRng.Address Then
                                    cb.Object.Value = True
                                    Exit For
                                End If
                            End If
                        Next cb
                        OnRng.Font.Color = vbRed
                    End If
                Next i
            Next ky

 يمكنك إختيار ما يناسبك 

 

 

فورمة - V4.xlsb

[mohanad2025]

كل الشكر للاخ  محمد هشام على مساعدته .. وفقكم الله لكل خير