كود ترتيب الخلايا ابجدي

[محمد عبد الناصر]

اريد ترتيب البيانات تحت بعضهم لكل عميل مع الحفاظ على رقم البند هذا ليس تسلسل ارقام لا اريد دمج البنود لكل عميل اريد فقط ترتيب الاسماء تحت بعضهم ابجدي 
الملف مرفق

جزاكم الله كل الخير                                                          تم التوضيح في الورقه الثانية 

 

12.xlsx

15.xlsx

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

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

اكنب في الورقة الثانية التنائج التي تتوقعها

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

Try this macro

Option Explicit
''''''''''''''''''''''''''''''''''''
Dim LR%, Ro%, S_rg As Range
Dim F_rg As Range, Where As Range
Dim i%, t%, LRK%, x%, m%
Dim y1%, y2%, ro_source%
'++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++
Sub TEST()
      Rem Created By Salim Hasbaya On 8/10/2020 _
        This macro working with merged cells _
        And sort Alpha the Data
 Application.ScreenUpdating = False
Dim Col As Object

Set S_rg = Source.Range("A3").CurrentRegion
Set Col = CreateObject("System.Collections.ArrayList")

Ro = S_rg.Rows.Count
SALIM.Range("K:K").ClearContents
SALIM.Range("A3").CurrentRegion.Clear
If Ro = 1 Then Exit Sub
Set S_rg = S_rg.Offset(1).Resize(Ro - 1)
For i = 3 To Ro + 2
 t = Source.Cells(i, 2).MergeArea.Rows.Count
  If Not Col.Contains(Source.Cells(i, 2).Value) Then
   Col.Add Source.Cells(i, 2).Value
  End If
 i = i + t
Next
    If Col(Col.Count - 1) = "" Then
      Col.Remove Col(Col.Count - 1)
    End If
Col.Sort

SALIM.Range("K1").Resize(Col.Count) = _
 Application.Transpose(Col.toarray)
 Set Col = Nothing
 Application.ScreenUpdating = True
End Sub
'+++++++++++++++++++++++++++++++++++
Sub get_data()
Application.ScreenUpdating = False
TEST
Dim p%, Merge_Rg As Range
ro_source = Source.Cells(Rows.Count, 2).End(3).Row
Set Where = Source.Range("B1:B" & ro_source)
LRK = SALIM.Cells(Rows.Count, "K").End(3).Row
m = 3
For x = 1 To LRK
      Set F_rg = Where.Find(SALIM.Cells(x, "K"), Lookat:=1)
      If Not F_rg Is Nothing Then
      y1 = F_rg.Row: y2 = y1
      Do
          t = F_rg.MergeArea.Rows.Count
          
          SALIM.Cells(m, 2) = Source.Cells(y2, 2)
          SALIM.Cells(m, 4) = Source.Cells(y2, 4)
          SALIM.Cells(m, 2).Resize(t).Merge
          SALIM.Cells(m, 4).Resize(t).Merge
          
          Set Merge_Rg = Source.Cells(y2, 1).Resize(t)
          
          For p = 1 To Merge_Rg.Rows.Count
              SALIM.Cells(m, 1).Offset(p - 1) = _
              Merge_Rg.Cells(p)
              SALIM.Cells(m, 3).Offset(p - 1) = _
              Merge_Rg.Cells(p).Offset(, 2)
          Next
          
          m = m + t
          Set F_rg = Where.FindNext(F_rg)
          y2 = F_rg.Row
          If y2 = y1 Then Exit Do
      Loop
      End If
Next
 
 With SALIM.Range("A3").CurrentRegion
  .Borders.LineStyle = 1
  .InsertIndent 1
  .Font.Size = 16: .Font.Bold = True
  .HorizontalAlignment = 3
  .VerticalAlignment = 2
  .Interior.ColorIndex = 35
 End With
 
 SALIM.Range("K:K").ClearContents
 Application.ScreenUpdating = True
End Sub

File Included

Abd_Naser.xlsm

[محمد عبد الناصر]

ماشاء الله عليك استاذ سليم تقوم بتنفيذ احسن من ما اتمناه تسلم يدك وعقلك وبارك الله في علمك وجعله في وازين حسناتك