مساعدة في استخرج من اسم الموظف اذاكان له اخ او اب في الشركه

أمير ادم · السبت at 23:00

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

كل عام ومنتدانا الجميل وكل مشرفيه واعضائه بكل خير وجعل الله شهركم الكريم مبارك عليكم وعلى الامه العربيه والاسلاميه بكل خير

الساده المحترمين

لدي جدول يحتوي على بيانات الموظفين اريد ان يخبرني عند ادخال اسم الموظف رباعيا او ثلاثيا ياتي ليه بكنيته اذا كان اب او اخ او اخت ومن ثم ياتي لي باسمه

حاولت ان اعدل في كود استخرج المحافظة والنوع والديانه من الرقم القومي ولكن بات بالفشل اريد مساعدتي في هذا الامر

مرفق الكود الذي تمت المحاوله عليه وباتت بالفشل ههههههههه

Option Explicit
'           بسم الله الرحمن الرحيم
'           ********************
'==============================================
Function Kh_Date_Sex_Province(MyNumber As Variant, MyTest As Byte)
Dim MyProvinces As Variant
Dim r As Integer
Dim yy As String
Dim ty As String * 1
Dim d As String * 2, m As String * 2, y As String * 2 _
, x As String * 2, xx As String * 2
'==============================================
MyProvinces = Array("01/ "35/اخت", "32/اب", "31/اخ")
'==============================================
Kh_Date_Sex_Province = ""
On Error GoTo 1
If Len(Trim(NameEmployee)) = 0 Then
    GoTo 1
End If
If Not IsNumeric(NameEmployee) Or Len(NameEmployee) <> 14 Then
    Kh_Date_Sex_Province = ""
    GoTo 1
End If
If MyTest = 1 Then
    d = Mid(NameEmployee, 6, 2)
    m = Mid(NameEmployee, 4, 2)
    y = Mid(NameEmployee, 2, 2)
    ty = Left(NameEmployee, 1)
    Select Case ty
        Case "2": yy = y
        Case "3": yy = "20" & y
        Case Else: yy = ""
    End Select
    If yy <> "" Then Kh_Date_Sex_Province = DateSerial(yy, m, d)
ElseIf MyTest = 2 Then
    If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then _
    yy = "اخ" Else yy = "ابن"
    Kh_Date_Sex_Province = yy
ElseIf MyTest = 3 Then
    x = Mid(MyNumber, 8, 2)
    For r = LBound(MyProvinces) To UBound(MyProvinces)
        xx = MyProvinces(r)
        If x = xx Then
            Kh_Date_Sex_Province = Right(MyProvinces(r), Len(MyProvinces(r)) - 3)
            Exit For
        End If
    Next
End If
1:
End Function

وهذا هو الكود الاصلي

Option Explicit
'           بسم الله الرحمن الرحيم
'           ********************
'            دالـــــــــــــــة
'           Kh_Date_Sex_Province
'  ( استخراج تاريخ الميلاد او النوع (ذكر - انثى
'       او المحافظة من الرقم القومي
'==============================================
'                  MyTest
'    اذا كانت = 1  تقوم باستخراج تاريخ الميلاد
'          اذا كانت = 2  تقوم باستخراج النوع
'         اذا كانت = 3  تقوم باستخراج المحافظة
'----------------------------------------------
'         MyProvinces  في متغير الجدول
'   بنفس الطريقة الرقم اولا ثم "/" ثم اسم المحافظة
'                             :  مثال على ذلك
'               "01/القاهرة"
'==============================================
Function Kh_Date_Sex_Province(MyNumber As Variant, MyTest As Byte)
Dim MyProvinces As Variant
Dim r As Integer
Dim yy As String
Dim ty As String * 1
Dim d As String * 2, m As String * 2, y As String * 2 _
, x As String * 2, xx As String * 2
'==============================================
MyProvinces = Array("01/القاهرة", "02/الإسكندرية", "12/الدقهلية", "13/الشرقية" _
, "14/القليوبية", "15/كفر الشيخ", "16/الغربية", "17/المنوفية", "18/البحيرة" _
, "19/الإسماعيلية", "21/الجيزة", "22/بني سويف", "24/المنيا", "25/أسيوط" _
, "26/سوهاج", "27/قنا", "28/أسوان", "29/الأقصر", "33/مطروح", "23/الفيوم", "88/خارج الجمهورية", "11/دمياط", "04/السويس", "03/بورسعيد", "34/شمال سيناء", "35/جنوب سيناء", "32/الوادي الجديد", "31/البحر الأحمر")
'==============================================
Kh_Date_Sex_Province = ""
On Error GoTo 1
If Len(Trim(MyNumber)) = 0 Then
    GoTo 1
End If
If Not IsNumeric(MyNumber) Or Len(MyNumber) <> 14 Then
    Kh_Date_Sex_Province = ""
    GoTo 1
End If
If MyTest = 1 Then
    d = Mid(MyNumber, 6, 2)
    m = Mid(MyNumber, 4, 2)
    y = Mid(MyNumber, 2, 2)
    ty = Left(MyNumber, 1)
    Select Case ty
        Case "2": yy = y
        Case "3": yy = "20" & y
        Case Else: yy = ""
    End Select
    If yy <> "" Then Kh_Date_Sex_Province = DateSerial(yy, m, d)
ElseIf MyTest = 2 Then
    If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then _
    yy = "ذكر" Else yy = "أنثى"
    Kh_Date_Sex_Province = yy
ElseIf MyTest = 3 Then
    x = Mid(MyNumber, 8, 2)
    For r = LBound(MyProvinces) To UBound(MyProvinces)
        xx = MyProvinces(r)
        If x = xx Then
            Kh_Date_Sex_Province = Right(MyProvinces(r), Len(MyProvinces(r)) - 3)
            Exit For
        End If
    Next
End If
1:
End Function

مرفق قاعدة البيانات للعمل عليه

شكرا لكم مقدما

emp.rar

**Foksh** · السبت at 23:14

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

جرب فكرتي البسيطة ..

Private Sub NameEmployee_AfterUpdate()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strEmpName As String
    Dim arrName() As String
    Dim lastName As String
    Dim relation As String
    Dim empID As Integer
    Dim found As Boolean
    
    Set db = CurrentDb()
    
    strEmpName = Me.NameEmployee
    
    arrName = Split(strEmpName, " ")
    
    If UBound(arrName) >= 2 Then
        lastName = arrName(UBound(arrName))
    Else
        MsgBox "يجب إدخال الاسم ثلاثيًا على الأقل.", vbExclamation, "تنبيه"
        Exit Sub
    End If
    
    Set rs = db.OpenRecordset("SELECT IDeMP, NameEmployee FROM DatEmp WHERE NameEmployee Like '*" & lastName & "' AND IDeMP <> " & Me.IDeMP)
    
    found = False
    Do While Not rs.EOF
        If InStr(rs!NameEmployee, lastName) > 0 Then
            If InStr(rs!NameEmployee, arrName(0)) > 0 Then
                relation = "ابن"
            ElseIf InStr(rs!NameEmployee, arrName(1)) > 0 Then
                relation = "أخ"
            Else
                relation = "أخت"
            End If
            
            Me.EntityEmployee = relation
            Me.NameVerificationEmployee = rs!NameEmployee
            found = True
            Exit Do
        End If
        rs.MoveNext
    Loop
    
    If Not found Then
        Me.EntityEmployee = ""
        Me.NameVerificationEmployee = ""
    End If
    
    rs.Close
    Set rs = Nothing
    Set db = Nothing
End Sub

emp.7z

أمير ادم · السبت at 23:26

Foksh

اخي واستاذي Foksh المحترم

اولا شكرا لك على مرورك الكريم وسرعة الاستجابه

هذا بالفعل هوا المطلوب ولكن قابلني مشكله بسيطه جدا وهي

من المفترض اذا كان لدي موظف اسمه( صابر عبداللطيف عبد الرحمن عبد العزيز) وهو موظف لدينا

ومن ثم تعيين ابنه وهو ( نسمه صابر عبداللطيف عبد الرحمن عبد العزيز) من المفترض ان ياتي لي بالكنيه (اب) واسمه(صابر عبداللطيف عبد الرحمن عبد العزيز) ولكن بياتي لي بالاسم بالفعل ولكن الكنيه لم تظبط معي مثل هذه الصورة

image.png.2dd40b1d40e5ba5c9ea3a87d03d0988e.png

من المفترض ان ياتي لي بالكنيه ابنه مثلا

هل من الممكن ان يكون مثل بيانات الجدول هذا

شكرا لك اخي الكريم

تم تعديل السبت at 23:33 بواسطه أمير ادم

**Foksh** · الأحد at 00:26

59 دقائق مضت, أمير ادم said:

هل من الممكن ان يكون مثل بيانات الجدول هذا

جرب التعديل التالي عله يكون الحل الذي تريده :-

Private Sub NameEmployee_AfterUpdate()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strEmpName As String
    Dim arrName() As String
    Dim lastName As String
    Dim relation As String
    Dim empID As Integer
    Dim found As Boolean
    Dim isFemaleName As Boolean
    Dim i As Integer
    
    Set db = CurrentDb()
    
    strEmpName = Me.NameEmployee
    arrName = Split(strEmpName, " ")
    
    If UBound(arrName) >= 2 Then
        lastName = ""
        For i = 1 To UBound(arrName)
            If i > 1 Then lastName = lastName & " "
            lastName = lastName & arrName(i)
        Next i
    Else
        MsgBox "يجب إدخال الاسم ثلاثيًا على الأقل", vbExclamation + vbMsgBoxRight, "تنبيه"
        Exit Sub
    End If
    
    isFemaleName = (Right(arrName(0), 1) = "ه" Or Right(arrName(0), 1) = "ة")
    
    Set rs = db.OpenRecordset("SELECT IDeMP, NameEmployee FROM DatEmp WHERE IDeMP <> " & Me.IDeMP)
    
    found = False
    Do While Not rs.EOF
        Dim otherEmpName() As String
        otherEmpName = Split(rs!NameEmployee, " ")
        
        If UBound(otherEmpName) >= 1 Then
            If arrName(1) = otherEmpName(0) Then
                Dim matchFound As Boolean
                matchFound = True
                
                If UBound(arrName) >= 2 And UBound(otherEmpName) >= 2 Then
                    If arrName(2) <> otherEmpName(1) Then
                        matchFound = False
                    End If
                End If
                
                If matchFound Then
                    If isFemaleName Then
                        relation = "ابنة"
                    Else
                        relation = "ابن"
                    End If
                    Me.EntityEmployee = relation
                    Me.NameVerificationEmployee = rs!NameEmployee
                    found = True
                    Exit Do
                End If
            End If
        End If
        rs.MoveNext
    Loop
    
    If Not found Then
        Me.EntityEmployee = "لا يوجد"
        Me.NameVerificationEmployee = "فردي"
    End If
    
    rs.Close
    Set rs = Nothing
    Set db = Nothing
End Sub

أمير ادم · الأحد at 00:35

شكرا لك اخي الكريم

وجعلها لك في ميزان حسناتك

بالفعل هذا هو المطلوب

🌹

**Foksh** · الأحد at 00:41

4 دقائق مضت, أمير ادم said:

شكرا لك اخي الكريم

وجعلها لك في ميزان حسناتك

بالفعل هذا هو المطلوب

🌹

انتظر لحظة ، قمت بتجربة الكود على اسماء متنوعة ، والنتيجة غير مرضية بالنسبة لي ,, سأعدل في التالي لاحقاً

**Foksh** · الأحد at 00:46

التعديل الصحيح بنظري هو الآتي بإضافة دالة للتعامل مع "أ" أو "إ" أو "ا" أو "ه" أو "ة" :-

Private Function NormalizeArabicText(text As String) As String
    Dim result As String
    result = text
    
    result = Replace(result, "أ", "ا")
    result = Replace(result, "إ", "ا")
    result = Replace(result, "آ", "ا")
    
    result = Replace(result, "ة", "ه")
    
    NormalizeArabicText = result
End Function

Private Function GetLastName(nameArray() As String) As String
    If UBound(nameArray) >= 0 Then
        GetLastName = nameArray(UBound(nameArray))
    Else
        GetLastName = ""
    End If
End Function

Private Sub NameEmployee_AfterUpdate()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strEmpName As String
    Dim arrName() As String
    Dim lastName As String
    Dim relation As String
    Dim empID As Integer
    Dim found As Boolean
    Dim isFemaleName As Boolean
    Dim i As Integer
    Const MIN_MATCHING_NAMES = 2
    
    Set db = CurrentDb()
    
    strEmpName = Me.NameEmployee
    arrName = Split(strEmpName, " ")
    
    If UBound(arrName) >= 2 Then
        lastName = ""
        For i = 1 To UBound(arrName)
            If i > 1 Then lastName = lastName & " "
            lastName = lastName & arrName(i)
        Next i
    Else
        MsgBox "يجب إدخال الاسم ثلاثيًا على الأقل", vbExclamation + vbMsgBoxRight, "تنبيه"
        Exit Sub
    End If
    
    isFemaleName = (Right(NormalizeArabicText(arrName(0)), 1) = "ه")
    
    Set rs = db.OpenRecordset("SELECT IDeMP, NameEmployee FROM DatEmp WHERE IDeMP <> " & Me.IDeMP)
    
    found = False
    Do While Not rs.EOF
        Dim otherEmpName() As String
        Dim matchingNames As Integer
        
        otherEmpName = Split(rs!NameEmployee, " ")
        
        For i = 0 To UBound(arrName)
            arrName(i) = NormalizeArabicText(arrName(i))
        Next i
        
        For i = 0 To UBound(otherEmpName)
            otherEmpName(i) = NormalizeArabicText(otherEmpName(i))
        Next i
        
        If GetLastName(arrName) = GetLastName(otherEmpName) Then
            If UBound(otherEmpName) >= MIN_MATCHING_NAMES And UBound(arrName) >= MIN_MATCHING_NAMES + 1 Then
                If arrName(1) = otherEmpName(0) Then
                    matchingNames = 1
                    
                    For i = 2 To UBound(arrName)
                        If (i - 1) <= UBound(otherEmpName) Then
                            If arrName(i) = otherEmpName(i - 1) Then
                                matchingNames = matchingNames + 1
                            Else
                                Exit For
                            End If
                        End If
                    Next i
                    
                    If matchingNames > MIN_MATCHING_NAMES Then
                        If isFemaleName Then
                            relation = "ابنة"
                        Else
                            relation = "ابن"
                        End If
                        Me.EntityEmployee = relation
                        Me.NameVerificationEmployee = rs!NameEmployee
                        found = True
                        Exit Do
                    End If
                ElseIf UBound(arrName) >= MIN_MATCHING_NAMES And UBound(otherEmpName) >= MIN_MATCHING_NAMES Then
                    matchingNames = 0
                    
                    For i = 1 To UBound(arrName)
                        If i <= UBound(otherEmpName) Then
                            If arrName(i) = otherEmpName(i) Then
                                matchingNames = matchingNames + 1
                            Else
                                Exit For
                            End If
                        End If
                    Next i
                    
                    If matchingNames > MIN_MATCHING_NAMES Then
                        If isFemaleName Then
                            relation = "أخت"
                        Else
                            relation = "أخ"
                        End If
                        Me.EntityEmployee = relation
                        Me.NameVerificationEmployee = rs!NameEmployee
                        found = True
                        Exit Do
                    End If
                End If
            End If
        End If
        rs.MoveNext
    Loop
    
    If Not found Then
        Me.EntityEmployee = "لا يوجد"
        Me.NameVerificationEmployee = "فردي"
    End If
    
    rs.Close
    Set rs = Nothing
    Set db = Nothing
End Sub

تم تعديل الأحد at 01:05 بواسطه Foksh
تم تعديل الكود بإضافة تحقق من اسم العائلة أيضاً

تسجيل الدخول

مساعدة في استخرج من اسم الموظف اذاكان له اخ او اب في الشركه

الردود الموصى بها

أمير ادم

Foksh

أمير ادم

Foksh

أمير ادم

Foksh

Foksh

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information