فرز قيم في نطاق محدد مع حذف القيم المكررة

[أبوســـارة1973]

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

في الملف المرفق مطلوب فرز القيم الموجودة في النطاق z8:bm8 

في النطاق f8:y8

بحيث تكون القيمة المطلوب فروها تتكون من رقم في البداية ورقم في النهاية مع موجود حرف بينهما

وعدم الالتفات إلى القيم الأخرى مثل كلمة اجتماع أو كلمة راحة أو أي كلمة أخرى لا ينطبق عليها الشرط 

ثم مطلوب ترتيب القيم في النطاق 

f8:y8

ترتيباً تصاعدياً 

وهكذا في بقية الأسطر حتى السطر رقم 95

Book_11.xlsx

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

ربما ينفع هذا الماكرو

Option Explicit

Sub Test_Mots()
Dim Sh As Worksheet
Dim Ro%, i%, X%, m%
Dim arr()
Set Sh = Sheets("Sheet1")
Ro = Sh.Cells(Rows.Count, "E").End(3).Row
Sh.Range("F8:Y" & Ro).ClearContents
 For X = 8 To Ro
  For i = 26 To 65
        If Sh.Cells(X, i) Like "#?#" Then
          ReDim Preserve arr(m)
           arr(m) = Sh.Cells(X, i)
           m = m + 1
         End If
  Next i
    If m > 0 Then
       Sh.Cells(X, "F").Resize(, m) = arr
    End If

    Erase arr: m = 0
  Next X
  
End Sub

الملف مرفق

Abou_sara.xlsm

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

 و هذا الماكرو يوم بترتيب العناصر ابجدياً

Option Explicit

Sub Test_Mots_sorted()
Dim Sh As Worksheet
Dim Ro%, i%, X%
Dim KK As Object
Set Sh = Sheets("Sheet1")
Ro = Sh.Cells(Rows.Count, "E").End(3).Row
Sh.Range("F8:Y" & Ro).ClearContents
Set KK = CreateObject("System.Collections.Arraylist")
 For X = 8 To Ro
  For i = 26 To 65
        If Sh.Cells(X, i) Like "#?#" Then
         KK.Add Sh.Cells(X, i).Value
        End If
  Next i
  If KK.Count Then
    KK.Sort
    Sh.Cells(X, "F").Resize(, KK.Count) = KK.toarray
    KK.Clear
   End If

  Next X
  
End Sub

الملف من جديد

Abou_sara_sorted.xlsm

[أبوســـارة1973]

شكراً جزيلا أستاذنا الكبير 

ولكن يقوم الكود بتكرار القيم 

والمطلوب هو ذكر القيمة مرة واحدة فقط ، فلو تكررت مثلاً القيمة 

1B1

في النطاق 

Z8:BM8 

أكثر من مرة يقوم الكود بتسجيلها في النطاق 

Ff8:Y8

مرة واحدة فقط 

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

تم التعديل على الملف كما تريد

Option Explicit

Sub Test_Mots_sorted()
Dim Sh As Worksheet
Dim Ro%, i%, X%
Dim KK As Object
Set Sh = Sheets("Sheet1")
Ro = Sh.Cells(Rows.Count, "E").End(3).Row
Sh.Range("F8:Y" & Ro).ClearContents
Set KK = CreateObject("System.Collections.Arraylist")
 For X = 8 To Ro
  For i = 26 To 65
        If Sh.Cells(X, i) Like "#?#" Then
         If Not KK.Contains(Sh.Cells(X, i).Value) Then
             KK.Add Sh.Cells(X, i).Value
         End If
        End If
  Next i
  If KK.Count Then
    KK.Sort
    Sh.Cells(X, "F").Resize(, KK.Count) = KK.toarray
    KK.Clear
   End If

  Next X
  
End Sub

 

Abou_sara_sorted_Uniq.xlsm

[أبوســـارة1973]

ألف شكر وألف تحية لك أستاذنا الفاضل

سلُمت يداك 

[أحمد يوسف]

  أبوســـارة1973

فين انت من هذه الإجابات الممتازة ؟!!!

أين الضغط على الإعـــــجــــاب ؟!!!💙