أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على ali mohamed ali-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة منع ادخال البيانات بعدة شروط اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





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

هناك الكثير من الأكواد حول هذا الموضوع لكن الكود في هذا الملف يستطيع ان يفصل الاسماء المركبة حتى الاسم الرابع و أكثر مع ..



20-07-2019 09:40 مساء
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 

هناك الكثير من الأكواد  حول هذا الموضوع

لكن الكود في هذا الملف يستطيع ان يفصل الاسماء المركبة حتى الاسم الرابع و أكثر مع اضافة تنسيقات تلوينية للنتائج

و القدرة على اضافة بعض الأسماء الأولى للاسم المركب (عبد ,  أبو  ,  سيف  ,   جمال  الخ....)

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

 
 
  sep_complex_names_New.rar   تحميل rar مرات التحميل :(43)
الحجم :(21.864) KB


20-07-2019 10:31 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تجزئة الاسماء المركبة وفصلها عن الاسماء العادية
الله عليك أخي الحبيب سليم
بارك الله فيك وجزاك الله خير الجزاء

وحشتنا أعمالك يا جدو .. smile

20-07-2019 10:35 مساء
مشاهدة مشاركة منفردة [2]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تجزئة الاسماء المركبة وفصلها عن الاسماء العادية
لإثراء الموضوع هذه دالة معرفة من ورائع الأخ الحبيب اسلام عبد الله
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب

20-07-2019 10:43 مساء
مشاهدة مشاركة منفردة [3]
ali mohamed ali
مشرف على منتدى الاكسيل
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2017
رقم العضوية : 1757
المشاركات : 1766
الدولة : مصر
الجنس : ذكر
الدعوات : 2
يتابعهم : 0
يتابعونه : 68
قوة السمعة : 9632
عدد الإجابات: 46
 offline 
look/images/icons/i1.gif تجزئة الاسماء المركبة وفصلها عن الاسماء العادية
أحسنت استاذ بارك الله فيك وزادك الله من فضله
توقيع :ali mohamed ali
{ وَقُل رَّبِّ زِدْنِي عِلْمًا }
[ كن على يقين من اعمالنا نخطئ ومن اخطائنا نتعلم ولذلك لا شي مستحيل ]
ساهم دائماً فى حل أى مشكلة او أستفسار لديك مع إضافة رد بشكره
أو دعوة لمن قدم اليك المساعدة,فالجميع هنا يعمل على مساعدة
 الاخرين لوجه الله وان تحتسب له اجر عند الله

20-07-2019 11:27 مساء
مشاهدة مشاركة منفردة [4]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif تجزئة الاسماء المركبة وفصلها عن الاسماء العادية
لاحظت انه اذا تكرر الاسم الاول للاسم المكرر اكثر من مرة  تحدث مشاكل قي تطبيق الكود
مثلاً 
ابراهيم محمد سيف النصر سيف الاسلام السيد 
لذلك قمت بتعديل الكود كما يلي

Option Explicit
Sub split_names()
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


الملف الجديد مرفق

تم تحديث الملف في المشاركة الأولى بتاريخ 21/7/2019
 

21-07-2019 06:13 صباحا
مشاهدة مشاركة منفردة [5]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تجزئة الاسماء المركبة وفصلها عن الاسماء العادية
أخي وحبيبي سليم
يفضل دائماً في الموضوعات التي تقدم أن يوضع آخر تحديث في الموضوع مع وضع ملاحظة بتاريخ آخر تحديث لكي لا يتوه الأعضاء
بمعنى أن يتم تعديل المشاركة الأولى ووضع الملف الأخير بعد معالجة الأخطء إن وجدت أو بعد إضافة إضافات جديدة .. ثم الرد في الموضوع بأنه تم تحديث الموضوع بتاريخ كذا كنوع من التوثيق
بارك الله فيك وجزاك الله خيراً

21-07-2019 06:50 صباحا
مشاهدة مشاركة منفردة [6]
الصقر
مدير المنتدى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 2
المشاركات : 1824
الجنس : ذكر
الدعوات : 21
يتابعهم : 0
يتابعونه : 748
قوة السمعة : 19987
موقعي : زيارة موقعي
عدد الإجابات: 2
 offline 
look/images/icons/i1.gif تجزئة الاسماء المركبة وفصلها عن الاسماء العادية

جزاكم الله خيرا استاذ سليم
123


توقيع :الصقر

اخى العضو الكريم
اذا كنت ترى ان المنتدى مفيد لك
فكن سفيرا لنا بدعوة الاخرين للانضمام معنا
فالدال على الخير كفاعله





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


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:28 صباحا