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

[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

[Armia Nabil]

استاذ محمد شكرا جدا علي الشيت 

بس محتاج تعديل بسيط عند البحث في القائمة المنسدلة مثلا كتبت حرف ال ( ف ) يظهرلي كل ما هو حرف ال ف بالترتيب حرف ال ( ق )  يظهرلي كل ما هو بحرف ال ق بالترتيب وهكذا لكافة الحروف مثل المثال اللي حضرتك كنت عامله لما تضغط علي حرف ال A يظهرلك كل ما هو حرف ال A فقط بعد كدا حضرتك كتبت AL ظهرلك ماهو بحرف AL مثل البحث في شيت الاكسيل العادي عند الفلترة بمجرد كتابة اول حرف بيظهرلي الكلمات اللي بتبدا بالحرف الاول ولما اكتب الحرف التاني يظهرلي الكلمات اللي يتظهر بنفس اول حرفين وهكذا

تم تعديل يونيو 21 بواسطه Armia Nabil

[محمد هشام.]

لنجرب هذا مع إظافة الترتيب الأبجدي لعناصر  الـكومبوبوكس عند النقر المزدوج يتم ترتيب القائمة تلقائيا قبل العرض

Option Explicit
Dim WS As Worksheet
Dim OnRng As Variant
Dim ColArr As Long

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set WS = Sheets("داتا")
    Dim f As Worksheet: Set f = Sheets("Sheet1")
    Dim lastRow As Long, cnt As Boolean, i As Long
    
    cnt = False
    lastRow = f.Cells(f.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow
        If Trim(f.Cells(i, "A").Value) <> "" Then
            cnt = True
            Exit For
        End If
    Next i
    'A' إظهار القوائم لغاية أخر صف يتضمن تاريخ على عمود'
    If cnt Then
       If Target.Count = 1 And Not Intersect(Target, Range("C2:O" & lastRow)) Is Nothing Then
        '  OR
        ' C2:O100 تحديد اخر صف لإظهار القوائم يدويا بما يناسبك
'        If Target.Count = 1 And Not Intersect(Target, Range("C2:O100")) Is Nothing Then
            ColArr = Target.Column
            If xColumn(ColArr) Then
                On Error Resume Next
                OnRng = WS.Range(WS.Cells(2, ColArr), _
                                WS.Cells(WS.Rows.Count, ColArr).End(xlUp)).Value
                On Error GoTo 0
                
                If Not IsEmpty(OnRng) Then
                    If Not IsArray(OnRng) Then
                        ReDim OnRng(1 To 1, 1 To 1)
                        OnRng(1, 1) = WS.Cells(2, ColArr).Value
                    End If
                    Me.ComboBox1.List = Application.Transpose(OnRng)
                Else
                    Me.ComboBox1.List = Array()
                End If
                
                With Me.ComboBox1
                    .Height = Target.Height + 3
                    .Width = Target.Width
                    .Top = Target.Top
                    .Left = Target.Left
                    .Value = Target.Value
                    .Visible = True
                    .Activate
                End With
            Else
                Me.ComboBox1.Visible = False
            End If
        Else
            Me.ComboBox1.Visible = False
        End If
    Else
        Me.ComboBox1.Visible = False
    End If
End Sub

Private Sub ComboBox1_Change()
    Dim d1 As Object
    Dim tmp As String
    Dim i As Long

    Set d1 = CreateObject("Scripting.Dictionary")

    If Me.ComboBox1.Value = "" Then
        Me.ComboBox1.List = Application.Transpose(OnRng)
        Me.ComboBox1.DropDown
    Else
        tmp = UCase(Me.ComboBox1.Value) & "*"
        For i = 1 To UBound(OnRng, 1)
            If UCase(Trim(OnRng(i, 1))) Like tmp Then
                d1(Trim(OnRng(i, 1))) = ""
            End If
        Next i

        If d1.Count > 0 Then
            Me.ComboBox1.List = d1.Keys
            Me.ComboBox1.DropDown
        Else
            Me.ComboBox1.List = Array(Me.ComboBox1.Value)
            Me.ComboBox1.DropDown
        End If
    End If

    ActiveCell.Value = Me.ComboBox1.Value
End Sub

Private Sub ComboBox1_Click()
    Me.ComboBox1.List = Application.Transpose(OnRng)
    Me.ComboBox1.Activate
    Me.ComboBox1.DropDown
End Sub

Private Function xColumn(colNum As Long) As Boolean
    Select Case colNum
        Case 3, 4, 5, 9, 10, 11, 15
            xColumn = True
        Case Else
            xColumn = False
    End Select
End Function

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

Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    On Error Resume Next
    Dim listArr() As String, i As Long
    If Not IsEmpty(OnRng) Then
        ReDim listArr(1 To UBound(OnRng, 1))
        For i = 1 To UBound(OnRng, 1)
            listArr(i) = OnRng(i, 1)
        Next i
        Call filtre(listArr)
        Me.ComboBox1.List = listArr
    End If
    Me.ComboBox1.Value = ""
    Me.ComboBox1.Activate
    Me.ComboBox1.DropDown
    On Error GoTo 0
End Sub

Private Sub filtre(arr() As String)
    Dim i As Long, j As Long, temp As String, n As Long
    n = UBound(arr)
    For i = 1 To n - 1
        For j = i + 1 To n
            If StrComp(arr(i), arr(j), vbTextCompare) > 0 Then
                temp = arr(i): arr(i) = arr(j): arr(j) = temp
            End If
        Next j
    Next i
End Sub

 

 

تعديل 4 .xlsb

تم تعديل يونيو 23 بواسطه محمد هشام.
تنظيم الكود

[Armia Nabil]

شكرا جدا يامستر محمد تعبت حضرتك