kanory

طيب ضع الفانك هذا في وحدة نمطية Function Seperate_Digits(T As String) As String Dim i As Integer Dim C As String Dim Which_Letter As String If Len(T & "") = 0 Then Seperate_Digits = "" Exit Function End If For i = 1 To Len(T) C = Asc(Mid(T, i, 1)) Select Case C Case 46, 48 To 57 Which_Letter = Which_Letter & Mid(T, i, 1) Case 47 Which_Letter = "" End Select Next i Seperate_Digits = Which_Letter End Function ثم ضع الكود التاليى تحت حدث الزر On Error Resume Next Dim s As String, x As Integer s = "GRN" x = Seperate_Digits(Me!FATORA_NO) Me!FATORA_NO = Format(s & Str(x) + 1, "000") وافينا بالنتيجة

مش تفكير بس ... فنجان قهوة .. بارك الله فيك .. بالتوفيق

انظر الاستعلام النهائي .... 3733 (1).accdb

انشئ قاعدة جديدة وصمم نموذج وبه زر وضع تحت حدث عندالنقر على الزر هذا الكود ..... Dim objAcc As Access.Application Set objAcc = GetObject("C:\Users\ACER\Desktop\data1.accdb") objAcc.DoCmd.OpenQuery "Qre1" objAcc.Application.Quit Set objAcc = Nothing

تحت حدث عند الضغط على الزر لديك ضع هذا الكود 'Me.[FATORA_NO] = [FATORA_NO] + 1 On Error Resume Next DoCmd.RunCommand acCmdRecordsGoToNew Dim s As String, x As Integer s = "GRN" x = DCount("*", "101") + 1 Me!FATORA_NO = Format(s & Str(x), "000")

ما شاء الله تبارك الله تستاهل اخي صالح اسأل الله التوفيق والسداد

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

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

حياك الله وبالتوفيق ,,,,,

تفضل ---------->>>>>> New تطبيق Microsoft Office Access.mdb

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

شغل النموذج Kanory ولاحظ الاستعلام الناتج -------->>>>>> 2132172302_FMARK_Kanory.mdb

.هذه طريقة اخرى بدون كتابة اسماء الحقول وخاصة عندما تكون كثيرة ولكن بشرط ان تتشابه ترتيب الحقول في الجدولين Dim db As DAO.Database Dim rstFrom As Recordset Dim rstTo As Recordset Set db = CurrentDb Dim RC, i, r As Integer Set rstTo = db.OpenRecordset("tblB1", dbOpenDynaset) Set rstFrom = db.OpenRecordset("tblB", dbOpenDynaset) rstFrom.MoveFirst: rstFrom.MoveLast RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC rstTo.AddNew For r = 1 To rstFrom.Fields.Count - 1 rstTo.Fields(r) = rstFrom.Fields(r) Next r rstTo.Update rstFrom.MoveNext Next i rstTo.Close rstFrom.Close Set rstTo = Nothing Set rstFrom = Nothing Set db = Nothing Kan_355.accdb

اعمل لنا مثال مصغر وطبق الحماية عليه ... حتى نشوف مالذي يمكن فعله ...

الكود يضيف كل السجلات الموجود في الجدول وذلك عن طريق الكود التالي RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC هذا الكود الذي انت وضعت جزءا منه لا يضيف كل الحقول الا اذا كتبت وحددت له الحقول بالشكل التالي rs.AddNew السطر التالي يعبر عن الحقل ..... قم بتكرار السطر بعدد الحقول الموجودة لديك rstTo!codhesab = rstFrom!codhesab rstTo!الحقل الثاني = rstFrom!الحقل الثاني وهكذا rs.Update أرفق لنا الجدولين وبه بيانات تجريبية للتطبيق

مشاركة مع حبيبنا الاستاذ . حسام استبدل الكود بهذا >>>>>> If Me.m1.ListCount = 0 Then Me.m1.AddItem "م" & ";" & "الصنف" & ";" & "عدد" & ";" & "المبلغ" Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount Else Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount End If Dim i As Long, SumTotal As Long SumTotal = 0 For i = 1 To (Me.m1.ListCount - 1) SumTotal = SumTotal + Nz(Me.m1.ItemData(i), 0) Next i txtTotal = SumTotal

كان وضعت مثال للتطبيق .... على كل حال جرب الكود التالي .... أو ارفق ملفك للتعديل . On Error Resume Next If IsNull(Me.readtbl.Column(0)) Then MsgBox "The List Empty or Items in list not selected", vbCritical, "Caution" Exit Sub End If Me.ProgBar.Visible = True Dim x As Integer For x = x To 30000 Me.ProgBar.Value = x If x = 30000 Then Me.ProgBar.Visible = False End If Next x Dim i As Integer Dim tbl As String Dim SDest As String Dim SFileName As String SDest = Me.txtPath SFileName = Me.txtFileName For i = 0 To Me.readtbl.ListCount - 1 If Me.readtbl.Selected(i) = True Then tbl = Me.readtbl.Column(0, i) DoCmd.TransferSpreadsheet acExport, , tbl, SDest & "\" & SFileName & ".xlsx" End If Next i MsgBox "تم بحمد الله الانتهاء من عملية التصدير ", 0 + 64 + 1572864, "مبروك"

المنتدى مليئ بهذه الامثلة .... جرب البحث في المنتدى تجد ما يسرك ...

برنامج القلعة النماذج منبثقة ومشروطة انظر >>>>>>>

تفضل .... Dim db As DAO.Database Dim rstFrom As Recordset Dim rstTo As Recordset Set db = CurrentDb Dim RC, i As Integer Set rstTo = db.OpenRecordset("table2", dbOpenDynaset) Set rstFrom = db.OpenRecordset("table1", dbOpenDynaset) RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC rs.AddNew rstTo!codhesab = rstFrom!codhesab rs.Update rstFrom.MoveNext Next i rstTo.Close rstFrom.Close Set rstTo = Nothing Set rstFrom = Nothing Set db = Nothing

اعطينا معلومات اكثر <<<< هل البرنامج من تصميمك .... ربما عمل ليعمل لفترة ( حماية ) ما هي الرسالة التى تظهر ؟؟؟؟ ممكن ارفات الملف !!!

وهذه مشاركة مع الاستاذ. @Shivan Rekany >>>>>>> Kan_324.accdb

وهذه مشاركة مع أخي الاستاذ . حسام Kanory.rar

مجرد رأي : ملف الاكسل واحد ... صحيح عند تصدير الفصل أ ثم تصدير الفصل ب ثم ج د هـ تجد مشكلة في اسماء الطلاب وتداخلها ... فتضطر لمسح ملف الاكسل كل مرة ( ماذا لو جعلت ملف الاكسل قالب ) تكون افضل وفي كل مرة تصدير يطلب منك البرنامج اسم جديد ... اقضل انظر للمرفق الجديد وملف الاكسل الموجود فيه هو قالب لا يتغير بل يطلب منك اسم لكل تصدير وموقع للتصدير .... جرب المرفق وأعلمنا بالنتيجة .... kanory.rar

هذه الكلمه وغيرها من الكلمات يجب على المبرمج ان ينساها تماما ........... جرب المرفق ...... مثال.accdb