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

[faisal_kg]

السلام عليكم أساتذتنا الأفاضل..

منضم جديد للموقع.

حاولت البحث تكرارا عن كود vba لعمل قائمة منسدلة مع خاصية البحث تكون مشابهة للموجودة في Excel 365 (جهازي اكسل 2010) ...وجميع ماوجدته لا يفي بالمطلوب وما ابحث عنه هو:

*قائمة منسدلة مكررة في عدة صفوف والكتابة تكون في الخلية وليس في صندوق منفصل .

* تكون فيها خاصية البحث...

فعند بدء الكتابة  في الخلية بالاحرف الاولى من الكلمة تظهر الخيارات المطابقة مباشرة وتلقائيا في القائمة والتي تتقلص كلما زدت حرفا فيها (وليس ان تكتب الكلمة.. ثم "تضغط كليك" على سهم القائمة لتظهر الخيارات).

*يفضل أن لايشمل البحث جلب الخيارات المطابقة للاحرف الموجودة في وسط الكلمة او في جزئها الثاني ان وجد لو أمكن.

فمثلا في قائمة مكونة من عدة دول.. موجودة في العمود C  عند وضع المؤشر في خلية القائمة المنسدلة في العمود A ونقوم بكتابة الحرف a (لايهم capital/small) تظهر مباشرة في القائمة المنسدلة الدول فقط التي تبدأ بنفس الحرف مثل: Algeria, Albania , Austria, Australia,… ولا تظهر الدول التي في وسطها الحرف a مثل Mali أو الدول الموجود في بداية جزئها الثاني مثل South Africa ... وهكذا.

وشكرا

 

قائمة منسدلة مع البحث والاكمال التلقائي.xlsx

[محمد هشام.]

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

إدا كنت قد فهمت طلبك بشكل صحيح فربما هدا سيوفي بالغرض

Option Explicit
Dim WS As Worksheet
Dim OnRng As Variant

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set WS = Sheets("Sheet1")

    If Not Intersect([A2:A11], Target) Is Nothing And Target.Count = 1 Then
        OnRng = WS.Range("C2:C" & WS.Cells(WS.Rows.Count, "C").End(xlUp).Row).value
        Me.ComboBox1.List = Application.Transpose(OnRng)
        Me.ComboBox1.Height = Target.Height + 3
        Me.ComboBox1.Width = Target.Width
        Me.ComboBox1.Top = Target.Top
        Me.ComboBox1.Left = Target.Left
        Me.ComboBox1.value = Target.value
        Me.ComboBox1.Visible = True
        Me.ComboBox1.Activate
    Else
        Me.ComboBox1.Visible = False
    End If
End Sub

Private Sub ComboBox1_Change()
    If Me.ComboBox1.value <> "" Then
        Dim d1 As Object
        Set d1 = CreateObject("Scripting.Dictionary")
        Dim tmp As String
        tmp = UCase(Me.ComboBox1.value) & "*"
        
        Dim i As Long
        For i = 1 To UBound(OnRng, 1)
            If UCase(OnRng(i, 1)) Like tmp Then d1(OnRng(i, 1)) = ""
        Next i
        
        Me.ComboBox1.List = d1.Keys
        Me.ComboBox1.DropDown
    End If
    ActiveCell.value = Me.ComboBox1.value
End Sub

Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Me.ComboBox1.List = Application.Transpose(OnRng)
    Me.ComboBox1.Activate
    Me.ComboBox1.DropDown
End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then
        ActiveCell.Offset(1).Select
    End If
End Sub

 

قائمة منسدلة مع البحث والاكمال التلقائي.xlsb

تم تعديل فبراير 19 بواسطه محمد هشام.

[faisal_kg]

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

[Armia Nabil]

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

استاذ محمد هشام

تحية طيبة وبعد

محتاج اعمل vba نفس اللي حضرتك عامله بس محتاج تعديل علي الشيت المرفق كمثال 

ان عمود ال c ياخذ من عمود ال c  في شيت الداتا

وعمود ال d باخذ من عمود ال d في شيت الداتا 

وعمود ال e باخذ من عمود ال e في شيت الداتا 

وعمود ال i باخذ من عمود ال i في شيت الداتا

وعمود ال j باخذ من عمود ال j في شيت الداتا  

وعمود ال k باخذ من عمود ال k في شيت الداتا 

وعمود ال o باخذ من عمود ال o في شيت الداتا 

وهكذا بنفس الطريقة اللي حضرتك عملت بيها الشيت او الشرح السايق اللي حضرتك عامله 

 

تعديل .xlsm

[محمد هشام.]

تفضل أخي ضع الكود التالي في حدث ورقة Sheet1

Option Explicit
Dim OnRng As Variant
Dim Cnt As Long
Dim CrWS As Worksheet
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim dict As Object, lastRow As Long, i As Long, val As String, key As Variant, a As Variant
    On Error GoTo SupApp

    If Target.CountLarge > 1 Or Target.Row < 2 Or _
    Target.Row > 100 Then '  '<==== هنا قم بتعديل اخر صف لاظهار القوائم بما يناسبك
    ComboBox1.Visible = False
    Exit Sub
   End If
   
  If ComboBox1 Is Nothing Then Exit Sub
    Set CrWS = ThisWorkbook.Sheets("داتا")
          If CrWS Is Nothing Then Exit Sub

    Cnt = Target.Column
    Select Case Cnt
        Case 3, 4, 5, 9, 10, 11, 15
            lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row
            If lastRow < 2 Then
                ComboBox1.Visible = False
                Exit Sub
            End If

            a = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value
            Set dict = CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(a, 1)
                val = Trim(CStr(a(i, 1)))
                If val <> "" Then
                    If Not dict.Exists(val) Then
                        dict.Add val, Nothing
                    End If
                End If
            Next i

            If dict.Count > 0 Then
                ReDim OnRng(1 To dict.Count, 1 To 1)
                i = 1
                For Each key In dict.Keys
                    OnRng(i, 1) = key
                    i = i + 1
                Next key
            Else
                ReDim OnRng(1 To 1, 1 To 1)
                OnRng(1, 1) = ""
            End If

            With ComboBox1
                .List = Application.Transpose(OnRng)
                .Height = Target.Height + 3
                .Width = Target.Width
                .Top = Target.Top
                .Left = Target.Left
                .Value = Target.Value
                .Visible = True
                .Activate
            End With
        Case Else
            ComboBox1.Visible = False
    End Select

    Exit Sub

SupApp:
    ComboBox1.Visible = False
End Sub

Private Sub ComboBox1_Change()
    On Error Resume Next
    If Me.ComboBox1.Value <> "" Then
        Dim d1 As Object, i As Long
        Set d1 = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(OnRng, 1)
            If InStr(1, UCase(OnRng(i, 1)), UCase(Me.ComboBox1.Value), vbTextCompare) > 0 Then
                d1(OnRng(i, 1)) = ""
            End If
        Next i
        If d1.Count > 0 Then
            Me.ComboBox1.List = d1.Keys
            Me.ComboBox1.DropDown
        End If
    End If
    ActiveCell.Value = Me.ComboBox1.Value
End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then
        ActiveCell.Offset(1).Select
        ComboBox1.Visible = False
        KeyCode = 0
    ElseIf KeyCode = vbKeyEscape Then
        ComboBox1.Visible = False
        KeyCode = 0
    End If
End Sub
Private Sub ComboBox1_Click()
    On Error Resume Next
    If CrWS Is Nothing Then Exit Sub
    Dim lastRow As Long, xRng As Variant
    lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row
    If lastRow < 2 Then Exit Sub
    xRng = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value
    If Not IsArray(xRng) Then
        ReDim tmp(1 To 1, 1 To 1)
        tmp(1, 1) = xRng
        xRng = tmp
    End If

    Me.ComboBox1.List = Application.Transpose(xRng)
    Me.ComboBox1.Activate
    Me.ComboBox1.DropDown
End Sub

Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Me.ComboBox1.List = Application.Transpose(OnRng)
    Me.ComboBox1.Activate
    Me.ComboBox1.DropDown
End Sub

 

تعديل .xlsm