قائمة منسدلة بدون فراغات وبدون تكرار بالمعادلات وبالكود

[abouelhassan]

الاساتذة

قرأت موضوعات عدة بالمنتدى ولكنى فشلت 

احتاج قائمتين منسدلتين بدون تكرار او فراغات بالمعادلات وبالكود مع الشكر الجزيل

قائمة منسدلة بدون تكرار وبدون فراغات بالكود والمعادلات.xlsm

[Ali Mohamed Ali]

تفضل هناك كود من أعمل الأستاذ ياسر خليل

والمعادلة من أعمال الأستاذ سليم حاصبيا , لهما منا كل الحب والإحترام

Option Explicit
Sub UniqueSortedList()
    Dim Arr, X As Object
    Application.ScreenUpdating = False
    With CreateObject("System.Collections.ArrayList")
        Set X = .Clone: X.Add " "
        Sheets("Sheet1").Activate
        For Each Arr In Sheets("Sheet1").Range("m2", Range("M" & Rows.Count).End(xlUp)).Value
            If Arr <> "" Then
                If IsNumeric(Arr) Then
                    If Not .Contains(Arr) Then .Add Arr
                Else
                    If Not X.Contains(Arr) Then X.Add CStr(Arr)
                End If
            End If
        Next
        .Sort: X.Sort: .addRange X: Arr = Join(.ToArray, ",")
    End With
    Sheets("Sheet1").Activate
    With Sheets("Sheet1").Range("e4").Validation
        .Delete
        .Add xlValidateList, 1, 1, Arr
    End With
    Application.ScreenUpdating = True
End Sub

على الرغم ان هذا الموضوع تم تناوله أكثر من مرة وكان عليك البحث جيداً -تفضل

عمل قائمة منسدلة ديناميكية مطاطية بدون تكرار اى بند فيها

قائمة منسدلة بدون تكرار وبدون فراغات بالكود والمعادلات.xlsm

[abouelhassan]

الف شكر استاذ على

والشكر موصول للاساتذة الافاضل

استاذ سليم والاستاذ ياسر

احترامى

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

جرب هذا الملف

Option Explicit
Dim col As Object
Dim ro%, i%
Dim Sh As Worksheet
'++++++++++++++++++++++++++++++++++
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
  If Not Intersect(Target, Range("a:a")) Is Nothing _
   And Target.Count = 1 Then
   data_val
   Cells(2, "F") = Target
  End If
Application.EnableEvents = True
End Sub
'+++++++++++++++++++++++++++++++++++++++++
Sub data_val()

Set Sh = Sheets("Sheet1")
ro = Sh.Cells(Rows.Count, 1).End(3).Row
Set col = CreateObject("System.Collections.Arraylist")
  With Sh
      For i = 2 To ro
       If .Cells(i, 1) <> vbNullString And _
          Not col.Contains(.Cells(i, 1).Value) Then
          col.Add .Cells(i, 1).Value
        End If
      Next i
    
      With .Cells(2, "F").Validation
      .Delete: .Add 3, Formula1:=Join(col.toarray, ",")
      End With
    End With
End Sub

الملف مرفق

 

Abou_hasn_validation.xlsm

[abouelhassan]

تحفة حلو جدا استاذى والله ما اروعك بارك الله فيك

لى سؤال حاولت اغير العمود من A الى m

مكان القائمة من f2 الى 

("e:e50")

الكود لم يعمل خرجت من الشيت ورجعت ايضا لم يعمل

اشكرك من كل قلبى استاذى الغالى لقلبى استاذ سليم 

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

يجب تحرير السطر بهذا الشكل

With .Range("E2:E50").Validation

 

[abouelhassan]

حفظك الله استاذنا الغالى

Option Explicit
Dim col As Object
Dim ro%, i%
Dim Sh As Worksheet
'++++++++++++++++++++++++++++++++++
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
  If Not Intersect(Target, Range("m:m")) Is Nothing _
   And Target.Count = 1 Then
   data_val
   Cells(2, "e") = Target
  End If
Application.EnableEvents = True
End Sub
'+++++++++++++++++++++++++++++++++++++++++
Sub data_val()

Set Sh = Sheets("Sheet1")
ro = Sh.Cells(Rows.Count, 1).End(3).Row
Set col = CreateObject("System.Collections.Arraylist")
  With Sh
      For i = 2 To ro
       If .Cells(i, 1) <> vbNullString And _
          Not col.Contains(.Cells(i, 1).Value) Then
          col.Add .Cells(i, 1).Value
        End If
      Next i
    
      With .Range("E2:E50").Validation
      .Delete: .Add 3, Formula1:=Join(col.toarray, ",")
      End With
    End With
End Sub

تم التنفيذ وايضا الكود توقف 

اشكرك من قلبى

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

يجب استبدال الرفم 1 الذي هو رقم العامود " ِA " في هذا السطر الى رقم العامود M  اي  (13)

او استبداله الى "M"

ro = Sh.Cells(Rows.Count, "M").End(3).Row

و كذلك هنا

 If .Cells(i, "M") <> vbNullString And _
          Not col.Contains(.Cells(i, "M").Value) Then
          col.Add .Cells(i, "M").Value

 

[abouelhassan]

نفس الخطأ والله استاذى

ارجو الاطلاع بعد اذنك

كل الشكر والتقدير

Abou_hasn_validation.xlsm

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

القائمة المنسدلة في ُE2 وليس  E3  خيث اللون الأصفر عندك

 

[abouelhassan]

تم ويعمل مائة بالمائة

سلمت وسلمت يمينك وبارك الله لك وحفظك من كل شر

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

استاذى واخى فى الله استاذ سليم