الترقيم التلقائي

[amir_adam83]

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

لدي كود الترقيم التلقائي وهو 

TextID = "AD." & Replace(Nz(DMax("TextID", "Table", "TextID like 'AD." & Right(Year(Date), 2) & "*'"), "AD." & Right(Year(Date), 2) & "000"), "AD.", "") + 1

وهو يعمل بصوره ممتازه ولكن

عند البداء 

AD.210001

AD.210002

AD.210003

AD.210004

AD.210005

AD.210006

AD.210007

AD.210008

وهو يعمل بصوره اكثر من رائعه

 ولكن عند حذف رقم 

AD.210003

واخر رقم متوقف عنده العد التلقائي هو

AD.210008

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

AD.210009

واعتبر رقم

AD.210003

متواجد

اريده يتم البحث عن الارقام المفقوده

وياتي به وبعد هذا الرقم يبداء العد تلقائي

هل من طريقه

بارك الله فيكم

 

[kanory]

ممكن مرفق صغير للتعديل عليه .... لان الشغلة تحتاج عمل واكواد بارك الله فيك 

[أمير ادم]

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

تفضل

dbo_da.rar

[kanory]

بعد الانتهاء من اضافة الموظف قم بالضغط على حفظ ....... انظر المرفق ربما هو ما تريد ....

 

dbo_da_kan.accdb

[أمير ادم]

بارك الله فيك وجزاك الله خير الجزاء هذا بالفعل هو المطلوب 

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

مثل الصورة رقم واحد

وعند اضافة رقم صفر في البداية

ياتي بالترقيم الصحيح

وعند اضافة رقم 2 ياتي

بترقيم غير الترقيم رقم 1

 

 

[kanory]

استبدل الكود الموجود لديك بهذا الكود .....

On Error Resume Next
    Dim Db As DAO.Database
    Dim Rc As DAO.Recordset
    Dim ChequesFound
    Dim ChequeNoStart As Long
    Dim ChequeNoEnd As Long
    Dim i As Long
    Set Db = CurrentDb
    Set Rc = Db.OpenRecordset("SELECT SamoBrojevitxt([dbo_ID]) AS Brojevtxti FROM dbo_Tbl_Emp ORDER BY SamoBrojevitxt([dbo_ID]);")
    Do While Not Rc.EOF
        Rc.MoveNext
    Loop
    If Rc.RecordCount = 0 Then
       dbo_ID = "Em." & Right(Year(Date), 2) & "001"
        'MsgBox "No Records Found"
        GoTo cmdDisplay_Exit
    End If
    DoCmd.GoToRecord , "", acNewRec
    Rc.MoveFirst
    ChequesFound = Rc.GetRows(Rc.RecordCount)
    ChequeNoStart = ChequesFound(0, 0)
    ChequeNoEnd = ChequesFound(0, UBound(ChequesFound, 2))
    For i = ChequeNoStart To ChequeNoEnd
         If BinarySearch(ChequesFound, i) = False Then
         
         dbo_ID = "Em." & i
         GoTo cmdDisplay_Exit
        Else
        
        dbo_ID = "Em." & Replace(Nz(DMax("dbo_ID", "dbo_Tbl_Emp", "dbo_ID like 'Em." & Right(Year(Date), 2) & "*'"), "Em." & Right(Year(Date), 2) & "000"), "Em.", "") + 1

        End If
    Next i
cmdDisplay_Exit:
    Set Rc = Nothing
    Set Db = Nothing
    

 

[أمير ادم]

احسنت اخي الكريم بارك الله فيك 

وجزاك الله خير الجزاء

بالفعل هذا هو المطلوب شكرا لك

[kanory]

لكن لو فكرت منطقيا ...

انت اعتمدت على السنه في الترقيم .. صحيح

اذن ... سوف تواجه مشكلة العام القادم ... ليش

منطقيا ان كل عام له ترقيمه الخاص ... يعني كل سنه يبدأ ترقيم من جديد .... 

السؤال ... لك .... للتعلم .... كيف يمكن تعديل الكود السابق حتى نتلافى تلك المشكلة ؟؟؟

اريد انت تفكر بطرق حل تلك المشكلة برمجيا !!

 

[أمير ادم]

بالفعل قولك صحيح😃 استاذي الكريم  لكن انت استاذنا ونحن من هم يتعلمون منكم برك الله فيكم وجعلكم عونا لنا

تم تعديل تاريخ الكمبيوتر للعام المقبل 2022 بالفعل اتي لي EM.220010 ولم يعد من نقظة الصفر للعام الجديد

 

[kanory]

ههههه .... اذن حاول انقاذ الموقف .... بتعديل كودك  .... 😁

[أمير ادم]

كيف وانا لا اعلم😄

[kanory]

المنتدى للتعلم بارك الله فيك .....

حاول في الكود .... غير ... بدل ... ضيف .... احذف .... حتى تصل ... ما تخسر شيئ بل تكتسب خبرة 

[amir_adam83]

وجدت هذا الكود

Private Sub Form_BeforeInsert(Cancel As Integer)
On Error Resume Next
Dim xLast, xNext As Integer
Dim prtyr, prtTxt As Integer
prtyr = Right(DatePart("yyyy", Date), 2)
prtTxt = Left(DMax("dbo_ID", "dbo_Tbl_Emp"), 2)
xLast = DMax("dbo_ID", "dbo_Tbl_Emp", prtTxt = prtyr)
If IsNull(xLast) Then
xNext = 1
Else
xNext = Val(Mid(xLast, 3, 5)) + 1
End If
Me!dbo_ID = prtyr & Format(xNext, "00000")
End Sub

في

وهو يعمل بصوره صحيحه ولكن استاذي الكريم لماذا 

اذا حذفت رقم

1 ورقم2ورقم3و

ياتي بالترقيم رقم اربعه

ولم ياتي برقم 1-2-3

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

 

dbo_da_ka11n.rar

[kanory]

لان الكود ينظر لاول تريقيم في الجدول وليس الترقيم الذي انت تريده ( بداية الترقيم قي السنه ) انظر هذا الكود وتفحصة لتعرف ما الذي يجب عليك تعديلة ليفهم الكود بداية الترقيم Em.21001

    DoCmd.GoToRecord , "", acNewRec
    Rc.MoveFirst
    ChequesFound = Rc.GetRows(Rc.RecordCount)
    ChequeNoStart = ChequesFound(0, 0)
    ChequeNoEnd = ChequesFound(0, UBound(ChequesFound, 2))

اما الكود الذي وجدته فلا يعيد الارقام المفقودة !!!!!

[amir_adam83]

السلام عليكم استاذي الكريم @kanory

تم وضع وتعديل الكود

 

DoCmd.GoToRecord , "", acNewRec
    Rc.MoveFirst
    ChequesFound = Rc.GetRows(Rc.RecordCount)
    ChequeNoStart = ChequesFound(0, 0)
    ChequeNoEnd = ChequesFound(0, UBound(ChequesFound, 2))

ولكن المشكله تكمن كما هي ولا يوجد جديد

اولا: عند التحويل لعام جديد ياتي باول كود فقطEm.21001

وعند اضافة موظف جديد في نفس العام ياتيEm.20008

رغم اني اعمل بعام 2021

ثانيا

لا يستطيع الفصل بين العام الماضي والحالي

بعتذر على الاطالة في مساعدتي بارك الله فيكم

[kanory]

طيب ...

جرب المرفق ووافينا بالنتيجة ...

 

dbo_da_kan.accdb

[amir_adam83]

2 hours ago, kanory said:

طيب ...

جرب المرفق ووافينا بالنتيجة ...

 

dbo_da_kan.accdb 552 kB · 1 download

مشاء الله تبارك الله 

الله يعطيك الف عافية

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

تم اختبار حذف ارقام بعد رقم 1

وتم اعادة الترقيم للاقام التى تم حذفها

 

وتم اختباره على عام جديد يعمل بصوره مائه بالمائه

وهذا مايطلبه الكثير

لعله في ميزان حسناتك ان شاء الله

جزاك الله الف خير

شكرا جزيل

 

[kanory]

بارك الله فيك اخي امير وعلى سعة صدرك ...