لكن الكود في هذا الملف يستطيع ان يفصل الاسماء المركبة حتى الاسم الرابع و أكثر مع اضافة تنسيقات تلوينية للنتائج
و القدرة على اضافة بعض الأسماء الأولى للاسم المركب (عبد , أبو , سيف , جمال الخ....)
Option Explicit
Sub New_Split_Name()
Application.ScreenUpdating = False
Dim my_st$, st1, st2
Dim last_col%
Dim my_name, i%, k%, Col%, int_col%
Dim Lr%: Lr = Cells(Rows.Count, 1).End(3).Row
Dim mon_range As Range
Dim fin_rg As Range
Range("b2").Resize(Lr - 1, 10).Clear
Dim arr: arr = _
Array("سيف", "عبد", "أبو", "ابو", "عز", "صدر", "نور")
'++++++++++++++++++++++++++++++++++++++
Rem Array تستطيع ان تضيف اي بداية اسم مركب داخل هذا الــ
'+++++++++++++++++++++++++++++++++++++
For i = 2 To Lr
If Range("a" & i) = vbNullString Then GoTo Next_i
my_st = Trim(Range("a" & i))
my_name = Split(Trim(my_st))
Range("b" & i).Resize(1, UBound(my_name) + 1) = my_name
Next_i:
Next
'==============================
For i = 2 To Lr
last_col = Cells(i, Columns.Count).End(1).Column
Set mon_range = Range(Cells(i, 2), Cells(i, last_col))
For k = 1 To last_col - 1
If Not (IsError(Application.match(mon_range.Cells(k), arr, 0))) Then
st1 = mon_range.Cells(k): st2 = mon_range.Cells(k + 1)
mon_range.Cells(k).Delete Shift:=xlToLeft
mon_range.Cells(k) = st1 & " " & st2
End If
Next
Next
Set fin_rg = Range("a1").CurrentRegion
Lr = fin_rg.Rows.Count
Col = fin_rg.Columns.Count
With fin_rg.Offset(1).Resize(Lr - 1, Col - 1).Offset(, 1)
.Borders.LineStyle = 1: .Font.Bold = True
.InsertIndent 1: Columns.AutoFit
.SpecialCells(2).Interior.ColorIndex = 35
End With
Set mon_range = Nothing
Set fin_rg = Nothing
Application.ScreenUpdating = True
'===============================
End Sub