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

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


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





فصل الإسماء الآخيرة بعد الإسم الرباعى

السلام عليكم ورحمة الله وبركاته ارجوا من الساده العظماء فى هذا المنتدى الكبير التوصل الى معادلة يتم فيها فصل الإسماء الآ ..


موضوع مغلق


27-02-2021 02:17 مساء
ashraf_hertlion
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 18-09-2017
رقم العضوية : 540
المشاركات : 262
الجنس : ذكر
تاريخ الميلاد : 7-11-1971
يتابعهم : 14
يتابعونه : 1
قوة السمعة : 329
 offline 

السلام عليكم ورحمة الله وبركاته
ارجوا من الساده العظماء فى هذا المنتدى الكبير التوصل الى معادلة يتم فيها فصل الإسماء الآخيرة بعد الإسم الرباعى كما فى الملف المرفق والنتيجة التى سوف يتم الحصول عليها كما فى المثال وببساطه الاسم يكون مكون من 6 اسماء او 5 اسماء وانا محتاج ظهور الإسم رباعى فقط مع الأخذ فى الاعتبار الآسماء المركبه مثل عبدالله او عبدالرحمن .
الموضوع فى غاية الأهمية وذلك لتقديم الاقرار الضريبى لأنه يشترط الاسم رباعى فقط لايزيد ولا يقل عن الاسم الرباعى
وجزاكم الله خيرا مقدماً وعلى كل ما تقدموه لنا من مساعادات
 
 
  فصل الإسماء الآخيرة بعد الإسم الرباعى.xlsx   تحميل xlsx مرات التحميل :(4)
الحجم :(16.147) KB



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

=IF(LEN(B4)-LEN(SUBSTITUTE(B4," ",""))+1=4,B4,LEFT(B4,FIND("~",SUBSTITUTE(B4," ","~",4))))

Option Explicit

'         بسم الله الرحمن الرحيم            "
'         ********************           "

'       دالة استخراج اسم ولي الأمر         "
'========================================"
'     True =    kh_First  اذا كان        "
'        او اي رقم غير الصفر              "
'     تقوم باستخراج الاسم الاول            "
'========================================"
'    يامكانية معالجة الاسم المركب الاول      "
'    تلقائياً حسب  معايير معرفة لديها      "
'      Kh_Father_Replace  في الدالة       "
'       ويمكنك اضافة اي معيار آخر         "
'        بجانب المعايير الموجودة             "
'          MyArray  في المتغير              "
'      مع مراعاة وجود فراغ بداية
'           او نهاية المعيار
'========================================"
'-----------------------------------------------------------------

Function Kh_Father_Name(ByVal Name As String, Optional kh_First As Boolean) As String
Dim KhString As String, Kh_Mid As String, Kh_Rep  As String
Dim KhMyNo As Integer
    On Error GoTo Err_Kh_Father_Name
    If IsEmpty(Name) Then GoTo Err_Kh_Father_Name
    KhString = Kh_Father_Replace(Trim(Name)) & " "
    KhMyNo = InStr(1, KhString, " ", 1)
    If kh_First Then Kh_Mid = Trim(Mid(KhString, 1, KhMyNo)) Else _
    Kh_Mid = Trim(Mid(KhString, KhMyNo, Len(KhString)))
    Kh_Rep = Replace(Kh_Mid, "^", " ")
    Kh_Father_Name = Kh_Rep
        Exit Function
Err_Kh_Father_Name:
     Kh_Father_Name = ""
End Function
Private Function Kh_Father_Replace(ByVal Kh_Sub As String) As String
Dim MyArray, Ar
Dim Sn As String, Re As String
'====================================================
' يمكنك اضافة اي معيار آخر هنا بجانب المعايير الموجودة
MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله" _
    , " الدين", " الإسلام", " الاسلام", " الحق")
'====================================================
Sn = Kh_Sub
For Each Ar In MyArray
    Re = Replace(Ar, " ", "^")
    Sn = Replace(Sn, Ar, Re)
Next
Kh_Father_Replace = Sn
End Function
Function NoSpaces(InName As String) As String
Dim NewName As String, ThePrevStr As String, TheStr As String
Dim i As Integer
InName = Trim(InName)
For i = 1 To Len(InName)
    TheStr = Mid(InName, i, 1)
    If TheStr = " " And ThePrevStr = " " Then TheStr = ""
    If TheStr <> "" Then ThePrevStr = TheStr
    NewName = NewName & TheStr
Next
NoSpaces = NewName
End Function
Function PartsCount(InName As String) As Integer
If NoSpaces(InName) = "" Then Exit Function
Dim i As Integer, U As Integer
Do
    i = InStr(i + 1, InName, " ", 1)
    If i = 0 Then Exit Do Else U = i
Loop
PartsCount = U + 1
End Function
Function GoodPartOfName(InName As String, NumberOfPart As Integer) As String
'تستخدم هذه الدالة لتحديد الجزء المطلوب من الإسم
'وذلك عن طريق تحديد رقمه في NumberOfPart
'الاسم الاول = 1
'الثاني = 2
'.....وهكذا
Dim sCount As Integer, i As Integer, U As Integer, F As Long
Dim ThePart() As String, RealPart() As String
Dim SpecialNames() As String, SpecialKinds() As Byte, SpecialCounts As Long
Dim SpecialPart As Variant
InName = NoSpaces(Kh_Father_Replace(Trim(InName)) & " ")
If InName = "" Then Exit Function
sCount = PartsCount(InName)
If NumberOfPart > sCount Then Exit Function
If NumberOfPart < sCount Then sCount = sCount + 1
ReDim ThePart(1 To sCount)
ReDim RealPart(1 To sCount)
For i = 1 To sCount
    ThePart(i) = PartOfName(InName, i)
    If i = 1 Then
        SpecialPart = "'" & ThePart(i) & "'"
    Else
        SpecialPart = SpecialPart & "," & "'" & ThePart(i) & "'"
    End If
Next i
If SpecialCounts <> 0 Then
    i = 0
    ReDim SpecialNames(1 To SpecialCounts)
    ReDim SpecialKinds(1 To SpecialCounts)
End If
For i = 1 To sCount
SpecialPart = Null
If SpecialCounts <> 0 Then
    For F = 1 To SpecialCounts
        If ThePart(i) = SpecialNames(F) Then SpecialPart = SpecialKinds(F)
    Next F
End If
If IsNull(SpecialPart) Then
    U = U + 1
    RealPart(U) = ThePart(i)
ElseIf SpecialPart = 2 Then
    U = U + 1
    RealPart(U) = ThePart(i) & " " & ThePart(i + 1)
    i = i + 1
ElseIf SpecialPart = 1 Then
    If i = 1 Then
        U = U + 1
        RealPart(U) = ThePart(i)
    ElseIf InStr(1, RealPart(U), " ", 1) <> 0 Then
        U = U + 1
        RealPart(U) = ThePart(i)
    Else
        U = U
        RealPart(U) = RealPart(U) & " " & ThePart(i)
    End If
End If
Next i
GoodPartOfName = Replace(RealPart(NumberOfPart), "^", " ")
End Function
Function PartOfName(InName As String, NumberOfPart As Integer) As String
Dim TheSpaceNumber As Byte
Dim i As Integer, U As Integer
InName = NoSpaces(InName)
PartOfName = ""
If InName = "" Then Exit Function
Do
    U = i
    i = InStr(i + 1, InName, " ", 1)
    If i <> 0 Then
        TheSpaceNumber = TheSpaceNumber + 1
        If TheSpaceNumber = NumberOfPart Then Exit Do
    ElseIf TheSpaceNumber + 1 = NumberOfPart Then
        i = Len(InName) + 1
        Exit Do
    Else
        Exit Function
    End If
Loop
        PartOfName = Trim(Mid(InName, U + 1, i - U - 1))
End Function
Public Function StName(TheName As String)
'الاسم الأول
StName = GoodPartOfName(TheName, 1)
End Function
Public Function FatherName(TheName As String)
'اسم الأب
Dim MyFName As String
If Len(GoodPartOfName(TheName, 3)) > 0 Then
MyFName = GoodPartOfName(TheName, 2)
Else
MyFName = ""
End If
FatherName = MyFName
End Function
Public Function StGrndName(TheName As String)
'الجد الأول
Dim MyStGName As String
If Len(GoodPartOfName(TheName, 4)) > 0 Then
MyStGName = GoodPartOfName(TheName, 3)
Else
MyStGName = ""
End If
StGrndName = MyStGName
End Function
Public Function NdGrndName(TheName As String)
'الجد الثاني
Dim MyNdGName As String
If Len(GoodPartOfName(TheName, 5)) > 0 Then
MyNdGName = GoodPartOfName(TheName, 4)
Else
MyNdGName = ""
End If
NdGrndName = MyNdGName
End Function

وعليك بوضع هذه المعادلة بداية من الخلية C4 سحباً للأسفل
=StName($B4)&" "& FatherName($B4)&" "&StGrndName($B4)&" "&NdGrndName($B4)

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
= StName ($ B4) & "" & FatherName ($ B4) & "" & StGrndName ($ B4) & "" & NdGrndName ($ B4)
واذا كنت تريد استخدام معادلة عادية فيمكنك إستخدام هذه المعادلة 
=IF(LEN(B4)-LEN(SUBSTITUTE(B4," ",""))+1=4,B4,LEFT(B4,FIND("~",SUBSTITUTE(B4," ","~",4))))
 
 
= IF (LEN (B4) -LEN (SUBSTITUTE (B4, "", "")) + 1 = 4, B4, LEFT (B4, FIND ("~", SUBSTITUTE (B4, "", "~", 4 ))))
 
عرض الإجابة




27-02-2021 02:59 مساء
مشاهدة مشاركة منفردة [1]
ali mohamed ali
مشرف على منتدى الاكسيل
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2017
رقم العضوية : 1757
المشاركات : 1769
الدولة : مصر
الجنس : ذكر
الدعوات : 2
يتابعهم : 0
يتابعونه : 68
قوة السمعة : 9642
عدد الإجابات: 47
 offline 
look/images/icons/i1.gif فصل الإسماء الآخيرة بعد الإسم الرباعى
وعليكم السلام-يمكنك ذلك من خلال عدة دوال معرفة من أعمال أستاذنا الكبير عبدالله باقشير له منا كل المحبة والإحترام وبارك الله فى أعماله ورحم الله والديه
ويمكنك أيضاُ استخدام معادلةعادية لطلبك ان أردت وهى

=IF(LEN(B4)-LEN(SUBSTITUTE(B4," ",""))+1=4,B4,LEFT(B4,FIND("~",SUBSTITUTE(B4," ","~",4))))

Option Explicit

'         بسم الله الرحمن الرحيم            "
'         ********************           "

'       دالة استخراج اسم ولي الأمر         "
'========================================"
'     True =    kh_First  اذا كان        "
'        او اي رقم غير الصفر              "
'     تقوم باستخراج الاسم الاول            "
'========================================"
'    يامكانية معالجة الاسم المركب الاول      "
'    تلقائياً حسب  معايير معرفة لديها      "
'      Kh_Father_Replace  في الدالة       "
'       ويمكنك اضافة اي معيار آخر         "
'        بجانب المعايير الموجودة             "
'          MyArray  في المتغير              "
'      مع مراعاة وجود فراغ بداية
'           او نهاية المعيار
'========================================"
'-----------------------------------------------------------------

Function Kh_Father_Name(ByVal Name As String, Optional kh_First As Boolean) As String
Dim KhString As String, Kh_Mid As String, Kh_Rep  As String
Dim KhMyNo As Integer
    On Error GoTo Err_Kh_Father_Name
    If IsEmpty(Name) Then GoTo Err_Kh_Father_Name
    KhString = Kh_Father_Replace(Trim(Name)) & " "
    KhMyNo = InStr(1, KhString, " ", 1)
    If kh_First Then Kh_Mid = Trim(Mid(KhString, 1, KhMyNo)) Else _
    Kh_Mid = Trim(Mid(KhString, KhMyNo, Len(KhString)))
    Kh_Rep = Replace(Kh_Mid, "^", " ")
    Kh_Father_Name = Kh_Rep
        Exit Function
Err_Kh_Father_Name:
     Kh_Father_Name = ""
End Function
Private Function Kh_Father_Replace(ByVal Kh_Sub As String) As String
Dim MyArray, Ar
Dim Sn As String, Re As String
'====================================================
' يمكنك اضافة اي معيار آخر هنا بجانب المعايير الموجودة
MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله" _
    , " الدين", " الإسلام", " الاسلام", " الحق")
'====================================================
Sn = Kh_Sub
For Each Ar In MyArray
    Re = Replace(Ar, " ", "^")
    Sn = Replace(Sn, Ar, Re)
Next
Kh_Father_Replace = Sn
End Function
Function NoSpaces(InName As String) As String
Dim NewName As String, ThePrevStr As String, TheStr As String
Dim i As Integer
InName = Trim(InName)
For i = 1 To Len(InName)
    TheStr = Mid(InName, i, 1)
    If TheStr = " " And ThePrevStr = " " Then TheStr = ""
    If TheStr <> "" Then ThePrevStr = TheStr
    NewName = NewName & TheStr
Next
NoSpaces = NewName
End Function
Function PartsCount(InName As String) As Integer
If NoSpaces(InName) = "" Then Exit Function
Dim i As Integer, U As Integer
Do
    i = InStr(i + 1, InName, " ", 1)
    If i = 0 Then Exit Do Else U = i
Loop
PartsCount = U + 1
End Function
Function GoodPartOfName(InName As String, NumberOfPart As Integer) As String
'تستخدم هذه الدالة لتحديد الجزء المطلوب من الإسم
'وذلك عن طريق تحديد رقمه في NumberOfPart
'الاسم الاول = 1
'الثاني = 2
'.....وهكذا
Dim sCount As Integer, i As Integer, U As Integer, F As Long
Dim ThePart() As String, RealPart() As String
Dim SpecialNames() As String, SpecialKinds() As Byte, SpecialCounts As Long
Dim SpecialPart As Variant
InName = NoSpaces(Kh_Father_Replace(Trim(InName)) & " ")
If InName = "" Then Exit Function
sCount = PartsCount(InName)
If NumberOfPart > sCount Then Exit Function
If NumberOfPart < sCount Then sCount = sCount + 1
ReDim ThePart(1 To sCount)
ReDim RealPart(1 To sCount)
For i = 1 To sCount
    ThePart(i) = PartOfName(InName, i)
    If i = 1 Then
        SpecialPart = "'" & ThePart(i) & "'"
    Else
        SpecialPart = SpecialPart & "," & "'" & ThePart(i) & "'"
    End If
Next i
If SpecialCounts <> 0 Then
    i = 0
    ReDim SpecialNames(1 To SpecialCounts)
    ReDim SpecialKinds(1 To SpecialCounts)
End If
For i = 1 To sCount
SpecialPart = Null
If SpecialCounts <> 0 Then
    For F = 1 To SpecialCounts
        If ThePart(i) = SpecialNames(F) Then SpecialPart = SpecialKinds(F)
    Next F
End If
If IsNull(SpecialPart) Then
    U = U + 1
    RealPart(U) = ThePart(i)
ElseIf SpecialPart = 2 Then
    U = U + 1
    RealPart(U) = ThePart(i) & " " & ThePart(i + 1)
    i = i + 1
ElseIf SpecialPart = 1 Then
    If i = 1 Then
        U = U + 1
        RealPart(U) = ThePart(i)
    ElseIf InStr(1, RealPart(U), " ", 1) <> 0 Then
        U = U + 1
        RealPart(U) = ThePart(i)
    Else
        U = U
        RealPart(U) = RealPart(U) & " " & ThePart(i)
    End If
End If
Next i
GoodPartOfName = Replace(RealPart(NumberOfPart), "^", " ")
End Function
Function PartOfName(InName As String, NumberOfPart As Integer) As String
Dim TheSpaceNumber As Byte
Dim i As Integer, U As Integer
InName = NoSpaces(InName)
PartOfName = ""
If InName = "" Then Exit Function
Do
    U = i
    i = InStr(i + 1, InName, " ", 1)
    If i <> 0 Then
        TheSpaceNumber = TheSpaceNumber + 1
        If TheSpaceNumber = NumberOfPart Then Exit Do
    ElseIf TheSpaceNumber + 1 = NumberOfPart Then
        i = Len(InName) + 1
        Exit Do
    Else
        Exit Function
    End If
Loop
        PartOfName = Trim(Mid(InName, U + 1, i - U - 1))
End Function
Public Function StName(TheName As String)
'الاسم الأول
StName = GoodPartOfName(TheName, 1)
End Function
Public Function FatherName(TheName As String)
'اسم الأب
Dim MyFName As String
If Len(GoodPartOfName(TheName, 3)) > 0 Then
MyFName = GoodPartOfName(TheName, 2)
Else
MyFName = ""
End If
FatherName = MyFName
End Function
Public Function StGrndName(TheName As String)
'الجد الأول
Dim MyStGName As String
If Len(GoodPartOfName(TheName, 4)) > 0 Then
MyStGName = GoodPartOfName(TheName, 3)
Else
MyStGName = ""
End If
StGrndName = MyStGName
End Function
Public Function NdGrndName(TheName As String)
'الجد الثاني
Dim MyNdGName As String
If Len(GoodPartOfName(TheName, 5)) > 0 Then
MyNdGName = GoodPartOfName(TheName, 4)
Else
MyNdGName = ""
End If
NdGrndName = MyNdGName
End Function

وعليك بوضع هذه المعادلة بداية من الخلية C4 سحباً للأسفل
=StName($B4)&" "& FatherName($B4)&" "&StGrndName($B4)&" "&NdGrndName($B4)

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
= StName ($ B4) & "" & FatherName ($ B4) & "" & StGrndName ($ B4) & "" & NdGrndName ($ B4)
واذا كنت تريد استخدام معادلة عادية فيمكنك إستخدام هذه المعادلة 
=IF(LEN(B4)-LEN(SUBSTITUTE(B4," ",""))+1=4,B4,LEFT(B4,FIND("~",SUBSTITUTE(B4," ","~",4))))
 
 
= IF (LEN (B4) -LEN (SUBSTITUTE (B4, "", "")) + 1 = 4, B4, LEFT (B4, FIND ("~", SUBSTITUTE (B4, "", "~", 4 ))))
 
 
 
  فصل الإسماء الآخيرة بعد الإسم الرباعى.xlsm   تحميل xlsm مرات التحميل :(9)
الحجم :(30.314) KB

توقيع :ali mohamed ali
{ وَقُل رَّبِّ زِدْنِي عِلْمًا }
[ كن على يقين من اعمالنا نخطئ ومن اخطائنا نتعلم ولذلك لا شي مستحيل ]
ساهم دائماً فى حل أى مشكلة او أستفسار لديك مع إضافة رد بشكره
أو دعوة لمن قدم اليك المساعدة,فالجميع هنا يعمل على مساعدة
 الاخرين لوجه الله وان تحتسب له اجر عند الله



الكلمات الدلالية
الإسماء ، الآخيرة ، الإسم ، الرباعى ،


 










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

الساعة الآن 07:03 مساء