تقسيم وتوزيع محتويات حقل علي عدة حقول

الأخ طالب العلم :

عندي اقتراح على قدى :

ليه ما تجعل الجدول 6 حقول فقط وتدخل الاسم مفرد فى كل حقل

ويمكنك عمل استعلام يجمع الحقول الستة لتحصل على الاسم كاملا ويعتبر هذا الحقل السابع .

أشرف خليل

الأخ طالب علم2002

أعجبتني طريقة توضيحك للسؤال : أسماء الحقول ومثال على المطلوب وليت كل من سأل يهتم بهذا الجانب ولايضع سوى كلمتين وعبارات غامضة .

لقد عملت ببعض التجارب وعمل معي كودين ولكنهما لم يعجباني بسببط طولهما وتعقيدهما ولكن سأضعهما لك لتختار أحدهما أو يقوم أحد الأخوة بالتعديل عليه :

الاول = Left(Me![الاسم الكامل], InStr(Me![الاسم الكامل], " "))
        الثاني = Left(Right(Me![الاسم الكامل], Len([الاسم الكامل]) - Len([الاول])), _
        InStr(Right(Me![الاسم الكامل], Len([الاسم الكامل]) - Len([الاول])), " "))
        الثالث = Left(Right(Me![الاسم الكامل], Len([الاسم الكامل]) - (Len([الاول]) + _
        Len([الثاني]))), InStr(Right(Me![الاسم الكامل], Len([الاسم الكامل]) - (Len([الاول]) + _
        Len([الثاني]))), " "))
        الرابع = Left(Right(Me![الاسم الكامل], Len([الاسم الكامل]) - (Len([الاول]) + _
        Len([الثاني]) + Len(الثالث))), InStr(Right(Me![الاسم الكامل], Len([الاسم الكامل]) - _
        (Len([الاول]) + Len([الثاني]) + Len(الثالث))), " "))
        الخامس = Left(Right(Me![الاسم الكامل], Len([الاسم الكامل]) - (Len([الاول]) + _
        Len([الثاني]) + Len(الثالث) + Len(الرابع))), InStr(Right(Me![الاسم الكامل], _
        Len([الاسم الكامل]) - (Len([الاول]) + Len([الثاني]) + Len(الثالث) + Len(الرابع))), " "))
        السادس = Right(Me![الاسم الكامل], Len([الاسم الكامل]) - (Len([الاول]) + _
        Len([الثاني]) + Len([الثالث]) + Len(الرابع) + Len(الخامس)))

والثاني :

Dim فراغات(6)
Dim d As Integer
Dim الاسم_الأخير As String
If InStr([الاسم الكامل], " ") <> 0 Then _
الاول = Left([الاسم الكامل], InStr([الاسم الكامل], " ") - 1)

For i = 1 To Len([الاسم الكامل])
If Mid([الاسم الكامل], i, 1) = " " Then
d = d + 1
فراغات(d) = i
End If
Next
الاسم_الأخير = Trim(Right([الاسم الكامل], InStr(StrReverse([الاسم الكامل]), " ")))
If Not IsEmpty(فراغات(2)) Then
الثاني = Mid([الاسم الكامل], فراغات(1) + 1, فراغات(2) - فراغات(1) - 1)
Else
الثاني = الاسم_الأخير
Exit Sub
End If
If Not IsEmpty(فراغات(3)) Then
الثالث = Mid([الاسم الكامل], فراغات(2) + 1, فراغات(3) - فراغات(2) - 1)
Else
الثالث = الاسم_الأخير
Exit Sub
End If
If Not IsEmpty(فراغات(4)) Then
الرابع = Mid([الاسم الكامل], فراغات(3) + 1, فراغات(4) - فراغات(3) - 1)
Else
الرابع = الاسم_الأخير
Exit Sub
End If
If Not IsEmpty(فراغات(5)) Then
الخامس = Mid([الاسم الكامل], فراغات(4) + 1, فراغات(5) - فراغات(4) - 1)
Else
الخامس = الاسم_الأخير
Exit Sub
End If

If Not IsEmpty(فراغات(5)) Then السادس = الاسم_الأخير

ولك تحياتي

السلام عليكم و رحمة الله و بركاته

انظر هذا المثال

و هو يقوم بما تريد بحد أقصي خمس أسماء و يمكنك تعديله للزيادة

http://mypage.ayna.com/mtarafa/SplitName97.zip

الأخ مصرواي :

مثال أكثر من رائع وعجبني جدا .

الأخ ابو حمود : كان الله فى عونك هتفكر لمين ولا مين .

الأخ طالب العلم : ممكن أعرف هدفك من هذا التقسيم .

أشرف خليل

السلام عليكم و رحمة الله و بركاته

شكرا أخ أشرف

الأخ طالب علم ، أنا أيضاً طالب أعرف لماذا تريد ذلك ؟

الاخ ابو حمود والاخ مصراوي والاخ اشرف

السلام عليكم ورحمة الله وبركانه

اسف لتاخري في الرد لوجود بعض المشاغل لدي

واشكركم جزيل الشكر علي تعبكم معانا والذي يدل علي كرم اخلاقكم

بالنسبة لسؤال الاخ اشرف

هذا الكود طلبه مني احد الاخوة وفي الحقيقه لم استفسر منه عن فائدة هذا الكود وساخبركم إن شاء الله عن فائدته بعد الاستفسار عنه

ومرة اخري جزاكم الله كل خير وتقدير

السلام عليكم و رحمة الله و بركاته

لقد و جدت فائدة لهذا الموضوع :

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

و للحصول علي ذلك اما أن نسجل الأسم الرباعي فى أربعة حقول منفصلة أو نستخدم الكود السابق لتقسيم الاسم علي الأربعة حقو ل

مع ملاحظة أنه فى هذه الحالة يجب كتابة الاسماء التي تتكون من جزئين بدون فاصل فمثلا أبو حمود تكتب أبوحمود (بدون مسافة ) أو استخدام الكود ووضع المسافة يدويا ، أو تعديل الكود لفهم ذلك و هذا صعب نوعا ما

و شكرا

الأخ طالب علم

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

ضع الدالة التالية في الوحدة النمطية الخاصة بالنموذج :

Private Function NeatSplit(ByVal Expression As String, _
Optional ByVal Delimiter As String = " ", _
Optional ByVal Limit As Long = -1, _
Optional Compare As VbCompareMethod = vbBinaryCompare) _
As Variant

Dim varItems As Variant, i As Long

varItems = Split(Expression, Delimiter, Limit, Compare)

For i = LBound(varItems) To UBound(varItems)

If Len(varItems(i)) = 0 Then varItems(i) = Delimiter

Next i

NeatSplit = VBA.Strings.Filter(varItems, Delimiter, False)

End Function

وفي حدث عند نقر زر الأمر ضع :

Dim x As Variant
x = NeatSplit([الاسم الكامل])

For i = LBound(x) To UBound(x)

    Select Case i
    Case 0: الاول = x(i)
     Case 1: الثاني = x(i)
    Case 2: الثالث = x(i)
    Case 3: الرابع = x(i)
    Case 4: الخامس = x(i)
    Case 5: السادس = x(i)
    End Select

Next i

ولك تحياتي

الأخ/ ابو حمود

الأخ/ مصراوي

يعجبني إصراركما للوصول إلى النتائج الطيبة وهذا شيء مشرف بارك الله فيكما0

ما أوردتماه من شرح وأكواد عن هذا المضوع ليس بالشيء القليل وقد أعجبني الكود الأخير لأبو حمود (y) وكذلك نفس الشيء لمثال الأخ مصراوي (y)

لدي ملاحظة بسيطة وفي نفس الوقت هامه وهي:

المستخدم الجديد لأي برنامج قد يجهل بعض الأمور ومن المعروف وخاصة في المملكة العربية السعودية أنه لا بد من أضافة " بن " إلى الاسماء مثلاً : سمير بن سعود بن سمير السمير وعند محاولة إضافتها واجهتني مشكلة حيث أن الحقل الثاني أخذ كلمة بن والرابع اخذ "بن " فربما ينسى المستخدم لأي برنامج بهذا الكود فيدخل بن 0

الا يوجد لديكما حل لتعديل الأكواد لتجاوز هذه المشكله أفيدونا أنار الله بصيرتكم(i)

وجدت دالة يمكنها استبدال أي كلمة في عبارة وقمت ببعض التعديل عليها لتشمل جميع الكلمات في العبارة :

أضف الدالة للوحدة النمطية الخاصة بالنموذج :

Function sReplace(SearchLine As String, SearchFor As String, ReplaceWith As String)
    Dim vSearchLine As String, found As Integer
    Dim الجملة

       found = InStr(SearchLine, SearchFor)
       vSearchLine = SearchLine
    If found <> 0 Then
        vSearchLine = ""
        If found > 1 Then vSearchLine = Left(SearchLine, found - 1)
        vSearchLine = vSearchLine + ReplaceWith
        If found + Len(SearchFor) - 1 < Len(SearchLine) Then _
            vSearchLine = vSearchLine + Right$(SearchLine, Len(SearchLine) - found - Len(SearchFor) + 1)
    End If

    found = InStr(vSearchLine, SearchFor)
    الجملة = vSearchLine

    Do While found <> 0
            vSearchLine = Left(vSearchLine, found - 1)
            vSearchLine = vSearchLine + ReplaceWith
            vSearchLine = vSearchLine + Right$(الجملة, Len(الجملة) - found - Len(SearchFor) + 1)

            found = InStr(vSearchLine, SearchFor)
            الجملة = vSearchLine
    Loop

    sReplace = vSearchLine

End Function

استبدل السطر :

x = NeatSplit([الاسم الكامل])

بهذا السطر :

x = NeatSplit(sReplace([الاسم الكامل], "بن ", ""))

ولك تحياتي

الله يصبرك على غلبنا يا بو حمود

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

ثم استبدلة السطر

     x = NeatSplit([الاسم الكامل])

بالسطر

    x = NeatSplit(sReplace([الاسم الكامل], "بن ", ""))

إلا إنه يحدث خطأ في هذه الكلمة : NeatSplit

هل أغير شيء في الكود غير السطر المذكور 0 ماهو سبب الخطأ

ثم مذا تعني كلمة " جملة " الموجودة في الكود

أرزقك الله أعلى درجات الجنة

يبدو لي أنك حذفت الدالة المسماة NeatSplit التي ذكرته لك سابقا ، إذا كنت حذفتها فأعدها لأنها ماتزال مطلوبة في الكود .

وكلمة جملة متغير من نوع Variant وهي تأخذ السلسلة النصية بعد حذف بن الأولى .

ولك تحياتي

لا املك إلا الشكر والدعاء لك بالسعادة في الدارين

اخي ابو حمود

ساعتين كاملتين في المحاولات ليعمل الكود بالشكل الصحيح ولكن لا حول ولا قوة إلا بالله خرج الأمر عن طاقتي ولذلك وظعت قاعدة البيانات التي تحتوي على الكود على الرابط التالي :

http://mypage.ayna.com/mrsalnet

وهي باسم " Data1.zip"

أود كرماً أن تطلع عليها وتخبرني لماذ عاندي هذا الكود 0 وفقك الله

:o

الخطأ الأول :

حذفت الدالة ولم تعدها كما قلت لك .

الخطأ الثاني :

حذفت الأقواس المربعة من أسماء الحقول التي تحوي فراغات مثال :

الاسم الاول

والصحيح

[الاسم الاول]

أي اسم لأي كائن يحوي فراغ وتحب أن تستخدمه في VBA لآبد من وضعه بين القوسين المربعين .

الخطأ الثالث :

جعلت هذا السطر ضمن الكود :

Case 0: الاول = x(i)

ولايوجد لديك حقل بالاسم الأول .

امسح الموجود لديك كله بضغط Ctrl+A ثم Delete ثم ألصق الكود التالي كاملاً :

Option Compare Database

Function sReplace(SearchLine As String, SearchFor As String, ReplaceWith As String)
    Dim vSearchLine As String, found As Integer
    Dim الجملة

       found = InStr(SearchLine, SearchFor)
       vSearchLine = SearchLine
    If found <> 0 Then
        vSearchLine = ""
        If found > 1 Then vSearchLine = Left(SearchLine, found - 1)
        vSearchLine = vSearchLine + ReplaceWith
        If found + Len(SearchFor) - 1 < Len(SearchLine) Then _
            vSearchLine = vSearchLine + Right$(SearchLine, Len(SearchLine) - found - Len(SearchFor) + 1)
    End If

    found = InStr(vSearchLine, SearchFor)
    الجملة = vSearchLine

    Do While found <> 0
            vSearchLine = Left(vSearchLine, found - 1)
            vSearchLine = vSearchLine + ReplaceWith
            vSearchLine = vSearchLine + Right$(الجملة, Len(الجملة) - found - Len(SearchFor) + 1)

            found = InStr(vSearchLine, SearchFor)
            الجملة = vSearchLine
    Loop

    sReplace = vSearchLine

End Function

Private Sub Form_Current()

End Sub

Private Sub أمر10_Click()
Dim x As Variant
x = NeatSplit(sReplace([الاسم الكامل], "بن ", ""))
For i = LBound(x) To UBound(x)

    Select Case i
    Case 0: [الاسم الاول] = x(i)
    Case 1: [اسم الاب] = x(i)
    Case 2: [اسم الجد] = x(i)
    Case 3: [الاسم الاخير] = x(i)
    End Select

Next i

End Sub
Private Function NeatSplit(ByVal Expression As String, _
Optional ByVal Delimiter As String = " ", _
Optional ByVal Limit As Long = -1, _
Optional Compare As VbCompareMethod = vbBinaryCompare) _
As Variant

Dim varItems As Variant, i As Long

varItems = Split(Expression, Delimiter, Limit, Compare)

For i = LBound(varItems) To UBound(varItems)

If Len(varItems(i)) = 0 Then varItems(i) = Delimiter

Next i

NeatSplit = VBA.Strings.Filter(varItems, Delimiter, False)

End Function

ولك تحياتي

اخي ابو حمود

كلمت شكر لا تكفي أو توفيك حقك لكن لا نملك إلا الدعاء بأن الله يوفقك ويبلغك الفردوس الأعلى 0

هل يوجد لدى أحد الأعضاء أو المشرفين برنامج يحتوي على تقسيم الاسم الكامل إلى خمسة أقسام فقط وليست ستة يعني

اسم الأول

اسم الأب

اسم الجد

العائلة

الاسم الخامس

مع مراعاة أن (العائلة) أو ربما ( الاسم الخامس)

يحتوي على عبارة ( آل ) هكذا ( آل فلان ) يعني يوجد فراغ بين ( آل ) وبين ( فلان) مثلاً

كيف نتغلب على هذه المشكلة

أرجو من لديه هذا البرنامج أن يضع لنا رابط هنا لنقوم بتحميلة

شاكرا للجميع اهتمامهم

هذا تعديل للكود بفرض أن الاسم الرابع (العائلة) يمكن أن يكون فيه آل :

Dim x As Variant

x = NeatSplit(sReplace([الاسم الكامل], "بن ", ""))

For I = LBound(x) To UBound(x)

    Select Case I
    Case 0: الاول = x(I)
     Case 1: الثاني = x(I)
    Case 2: الثالث = x(I)
    Case 3: الرابع = x(I)
    Case 4
    الخامس = x(I)
    If الرابع = "آل" Then
    الخامس = ""
    الرابع = "آل " & x(I)
    End If
    Case 5: السادس = x(I)
    End Select

Next I

استخدمه بدلاً من الأسطر التالية :

Private Sub أمر10_Click()
Dim x As Variant
x = NeatSplit(sReplace([الاسم الكامل], "بن ", ""))
For i = LBound(x) To UBound(x)

    Select Case i
    Case 0: [الاسم الاول] = x(i)
    Case 1: [اسم الاب] = x(i)
    Case 2: [اسم الجد] = x(i)
    Case 3: [الاسم الاخير] = x(i)
    End Select

Next i

End Sub

والموجودة في الكود السابق ، يعني لاتغير سوى هذه الأسطر والباقي كله مطلوب .

جربه وإذا تريد تعديل آخر فاكتب طلبك .

ولك تحياتي

بعد التحية :

هذا كود لدالة لتقسيم الأسماء مع حلول لبعض مشاكل الأسماء المركبة مثل أسماء الهنود .

Function NameSplit(InName As String, PartNo As Byte) As String
  Dim FullName, Part, Part2 As String
  Dim K, Pos, Pos2 As Byte

  NameSplit = ""
  FullName = RTrim(LTrim(Nz(InName))) & " "

  For K = 1 To PartNo
    Pos = InStr(1, FullName, " ")
    Part = Left(FullName, Pos)
    If Part = "آل " Or Part = "عبد " Or Part = "عبدرب " Then
      Pos = InStr(Pos + 1, FullName, " ")
    Else
      Pos2 = InStr(Pos + 1, FullName, " ")
      If Pos2 > 0 Then
        Part2 = Mid(FullName, Pos + 1, Pos2 - Pos)
        Select Case Part2
          Case "الله ", "الحق ", "الإسلام ", "الدين "
            Pos = Pos2
        End Select
      End If
    End If
    If Pos = 0 Then Pos = Len(FullName) + 1
    Select Case K
      Case PartNo: NameSplit = Left(FullName, Pos - 1)
    End Select
    FullName = Mid(FullName, Pos + 1, Len(FullName))
  Next K
End Function

المدخلات :

1 - الإسم كاملا

2 - رقم الخانة للإسم المطلوب : 1 للأول 2 للثاني .. الخ

لاحدود .... :)

تحياتي

الأخ سعودي31

تم التغيير في الكود الموجود في حدث نقر زر الأمر حسب طلبك ، احذف الموجود وضع :

Dim x As Variant

x = NeatSplit(sReplace([الاسم الكامل], "بن ", ""))

For i = LBound(x) To UBound(x)

    Select Case i
    Case 0: الاول = x(i)
     Case 1: الثاني = x(i)
    Case 2: الثالث = x(i)
    Case 3: الرابع = x(i)
    Case 4
    الخامس = x(i)
    If الرابع = "آل" Or الرابع = "ال" Then
    الخامس = Null
    الرابع = "آل " & x(i)
    End If
    Case 5
    السادس = x(i)
    If IsNull(الخامس) Then
    الخامس = السادس
    السادس = Null
    End If
    End Select

Next i

ولك تحياتي

رابط آخر لمثالي

http://www14.brinkster.com/mtarafa/forms/S...SplitName97.zip

الاخ العزيز محمد طاهر

السلام عليكم ورحمة الله وبركاته وبعد

لقد حاولة ازال الملف من الموقع المحدد ولكن دون جدوى

قد يكون الرابط معطل

اكون شاكرا ومقدرا اذا تم ارساله على البريد مباشرا

ولك من جزيل الشكر والتقدير(f) (f) (f)

الاخ ابو حمود

السلام عليكم ورحمة الله وبركاته وبعد

من قال لا ادري فقد افتى

ولا حياة مع الياس ولا ياس مع الحياه

ستجد الرد قريبا إن شاء الله فانا الان مشغول بالاجتماعات في العمل

وفي غضون ايام ستجد الرد على على هذا الموقع الجميل

(f) (f) (f)

و ما هو بريدك ؟؟

لتنزيل الملف من الرابط السابق

انقر بالزر الايمن و اختار حفظ باسم

Save Target as