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

[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

تم تعديل أكتوبر 12 بواسطه عبدالله بشير عبدالله

[محمد هشام.]

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

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

 

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

تم تعديل أكتوبر 13 بواسطه محمد هشام.

[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

 

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

تم تعديل أكتوبر 13 بواسطه 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

تم تعديل أكتوبر 13 بواسطه محمد هشام.

[mahmoud nasr alhasany]

ماشاء الله احسنت ا/ هشام محمد انت رائع حقا

ماشاء الله احسنت ا/ هشام محمد انت رائع حقا