تجزئة الاسماء المركبة وفصلها عن الاسماء العادية

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