اذهب الي المحتوي
أوفيسنا

ترتيب البيانات فى combobox1,2

mahmoud nasr alhasany

بواسطه mahmoud nasr alhasany
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by محمد هشام.,

الردود الموصى بها

mahmoud nasr alhasany

mahmoud nasr alhasany

قام بنشر
قام بنشر

رجاء مساعدتى فى ترتيب البيانات فى combobox1,2 ترتيبا ابجديا 

Sub FillComboBoxesWithoutDuplicates()
    Dim ws As Worksheet
    Dim i As Long, lastRow As Long
    Dim storeNames As Collection
    Dim storeName As String
    ' تحديد ورقة العمل
    Set ws = ThisWorkbook.Sheets("Sheet3")
    ' تحديد آخر صف يحتوي على بيانات
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    ' إنشاء مجموعة لتخزين الأسماء الفريدة
    Set storeNames = New Collection
    ' قراءة الأسماء وإضافتها إلى المجموعة (مع التعامل مع التكرارات)
    On Error Resume Next
    For i = 2 To lastRow
        storeName = ws.Cells(i, "D").Value
        storeNames.Add storeName, storeName
        On Error GoTo 0
    Next i
    On Error GoTo 0
    ' مسح ComboBox1 و ComboBox2
    ComboBox1.Clear
    ComboBox2.Clear
    ' ملء ComboBox1 و ComboBox2 بالأسماء الفريدة
    For Each storeName In storeNames
        ComboBox1.AddItem storeName
        ComboBox2.AddItem storeName
    Next storeName
End Sub
Private Sub ComboBox1_Change()
     Dim selectedItem As String
    selectedItem = ComboBox1.Value ' الحصول على القيمة المحددة في ComboBox1
    ' البحث عن العنصر في ComboBox2 وإزالته
    Dim i As Long
    For i = ComboBox2.ListCount - 1 To 0 Step -1
        If ComboBox2.List(i) = selectedItem Then
            ComboBox2.RemoveItem i
            Exit For
        End If
    Next i
End Sub
Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    Dim i As Long, lastRow As Long
    Dim storeNames As New Collection
    Dim storeName As Variant
    Set ws = ThisWorkbook.Sheets("Sheet3")
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    On Error Resume Next
    For i = 2 To lastRow
        storeName = ws.Cells(i, "D").Value
        If Not IsEmpty(storeName) Then
            storeNames.Add storeName, storeName
        End If
    Next i
    On Error GoTo 0
    ComboBox1.Clear
    ComboBox2.Clear
    For Each storeName In storeNames
        ComboBox1.AddItem storeName
        ComboBox2.AddItem storeName
    Next storeName
End Sub

 

ترتيب البيانات ابجديا.xlsm

رابط هذا التعليق
شارك
عبدالله بشير عبدالله

عبدالله بشير عبدالله

قام بنشر
قام بنشر (معدل)

 الكود يرتب ابجدي ويحذف التكرار 

Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    Dim rng As Range
    Dim data As Variant
    Dim sortedData As Variant
    Dim uniqueData As Collection
    Dim i As Long, j As Long
    Dim temp As Variant

    Set ws = ThisWorkbook.Sheets("Sheet3")
    Set rng = ws.Range("D2:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row)

    data = rng.Value

    ReDim sortedData(1 To UBound(data, 1), 1 To 1)
    For i = 1 To UBound(data, 1)
        sortedData(i, 1) = data(i, 1)
    Next i

    For i = 1 To UBound(sortedData, 1) - 1
        For j = i + 1 To UBound(sortedData, 1)
            If sortedData(i, 1) > sortedData(j, 1) Then
                temp = sortedData(i, 1)
                sortedData(i, 1) = sortedData(j, 1)
                sortedData(j, 1) = temp
            End If
        Next j
    Next i

    Set uniqueData = New Collection
    On Error Resume Next
    For i = 1 To UBound(sortedData, 1)
        uniqueData.Add sortedData(i, 1), CStr(sortedData(i, 1))
    Next i
    On Error GoTo 0

    With Me.ComboBox1
        .Clear
        For i = 1 To uniqueData.Count
            .AddItem uniqueData(i)
        Next i
    End With

    With Me.ComboBox2
        .Clear
        For i = 1 To uniqueData.Count
            .AddItem uniqueData(i)
        Next i
    End With
End Sub

الملف

ترتيب البيانات ابجديا.xlsm

تم تعديل بواسطه عبدالله بشير عبدالله
  • Like 2
رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر (معدل)

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

 بعد إدن الاستاد @عبدالله بشير عبدالله    اليك حل اخر 

  

Option Compare Text 
Option Explicit
Dim f As Worksheet

Private Sub UserForm_Initialize()
    Set f = ThisWorkbook.Sheets("Sheet3")
    Dim j As Object, OneRng As Variant, i As Long, Tbl As Variant
    Set j = CreateObject("Scripting.Dictionary")
    OneRng = f.Range("D2:D" & f.Cells(f.Rows.Count, "D").End(xlUp).Row).Value
    
    ' تعبئة كومبوبوكس 1  بالقيم غير الفارغة والغير مكررة
    For i = LBound(OneRng, 1) To UBound(OneRng, 1)
        If OneRng(i, 1) <> "" Then j(OneRng(i, 1)) = ""
    Next i
    
    ' ترتيب أبجدي
    Tbl = j.Keys
    SrtArr Tbl, LBound(Tbl), UBound(Tbl)
    Me.ComboBox1.List = Tbl
End Sub
Private Sub ComboBox1_AfterUpdate()
    If f Is Nothing Then Set f = ThisWorkbook.Sheets("Sheet3")
    
    Dim j As Object, OneRng As Variant, i As Long, Tbl As Variant
    Set j = CreateObject("Scripting.Dictionary")
    OneRng = f.Range("D2:D" & f.Cells(f.Rows.Count, "D").End(xlUp).Row).Value
    
    '  تعبئة كومبوبوكس 2 بالقيم غير الفارغة والغير مكررة وأنها لا تطابق قيمة كومبوبوكس 1
    For i = LBound(OneRng, 1) To UBound(OneRng, 1)
        If (OneRng(i, 1) <> "") And (CStr(OneRng(i, 1)) <> Me.ComboBox1.Value) Then j(OneRng(i, 1)) = ""
    Next i
    ' ترتيب أبجدي
    Tbl = j.Keys
    SrtArr Tbl, LBound(Tbl), UBound(Tbl)
    Me.ComboBox2.Clear
    Me.ComboBox2.List = Tbl
End Sub
Sub SrtArr(a As Variant, gauc As Long, droi As Long)
    Dim ref As Variant, temp As Variant
    Dim g As Long, D As Long
    ref = a((gauc + droi) \ 2)
    g = gauc: D = droi
    Do
        Do While a(g) < ref: g = g + 1: Loop
        Do While ref < a(D): D = D - 1: Loop
        If g <= D Then
            temp = a(g): a(g) = a(D): a(D) = temp
            g = g + 1: D = D - 1
        End If
    Loop While g <= D
    If g < droi Then SrtArr a, g, droi
    If gauc < D Then SrtArr a, gauc, D
End Sub

 

ترتيب البيانات ابجديا v2.xlsm

تم تعديل بواسطه محمد هشام.
  • Like 1
رابط هذا التعليق
شارك
mahmoud nasr alhasany

mahmoud nasr alhasany

قام بنشر
  • الكاتب
قام بنشر (معدل)

اولا اشكر  السيدان  الفضلاء الرائعان

عبدالله بشير عبدالله

محمد هشام.    

على هذا المجهود الرائع

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

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

مخزن 1
مخزن 10
مخزن 11
مخزن 12
مخزن 13
مخزن 14
مخزن 2
مخزن 3
مخزن 4
مخزن 5
مخزن 6
مخزن 7
مخزن 8
مخزن 9

 

وانا اردت ان تكون الترتيب فى الكومبوبوكس 1و2 هكذا

مخزن 1
مخزن 2
مخزن 3
مخزن 4
مخزن 5
مخزن 6
مخزن 7
مخزن 8
مخزن 9
مخزن 10
مخزن 11
مخزن 12
مخزن 13
مخزن 14

 

وشكرا جزيلا لكم على انكم وجدت وقتا لمساعدتنا

تم تعديل بواسطه mahmoud nasr alhasany
رابط هذا التعليق
شارك
  • أفضل إجابة
محمد هشام.

محمد هشام.

قام بنشر
  • أفضل إجابة
قام بنشر (معدل)

ادن قم بتغيير الجزء الأخير من الكود على الشكل التالي ليتناسب مع طلبك  

Private Sub ComboBox1_AfterUpdate()
'Code................
' ترتيب أبجدي
    Tbl = j.Keys
    SrtArr Tbl
    Me.ComboBox2.Clear
    Me.ComboBox2.List = Tbl
End Sub
'============
Sub SrtArr(a As Variant)
    Dim temp As Variant
    Dim i As Long, j As Long
    Dim num1 As Long, num2 As Long
    Dim txt1 As String, txt2 As String

    For i = LBound(a) To UBound(a) - 1
        For j = i + 1 To UBound(a)
            
            txt1 = Trim(Split(a(i), " ")(0))
            On Error Resume Next
            num1 = CLng(Split(a(i), " ")(1))
            On Error GoTo 0
            
            txt2 = Trim(Split(a(j), " ")(0))
            On Error Resume Next
            num2 = CLng(Split(a(j), " ")(1))
            On Error GoTo 0
            
            If num1 > num2 Then
                temp = a(i)
                a(i) = a(j)
                a(j) = temp
            End If
        Next j
    Next i
End Sub

 

 

ترتيب البيانات ابجديا v3.xlsm

تم تعديل بواسطه محمد هشام.
  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept