نجوم المشاركات

أستاذي الكبير @jjafferr الان موافقين 🏂 وين المكان ؟؟؟ أخي الغالي @ابا جودى .. وييييييينك أخي أشتقت ألك أخي قلقت عليك .. ما سبب أنقطاعك المفاجء ؟؟؟

طالما هناك عشاء لا تقلق 😋 لن نتأخر عنكم ابدا أستاذى دائما نحن فى الخدمة

اخجلتونا يا جماعة 🙂 خلاص ، وبهذه المناسبة ، العشاء على حسابي الليلة ، والجميع مدعو 🙂 جعفر

حيث انك عضو جديد يمكن تجربة هذا الملف لكن في المرة القادمة الملف ضروري monney.xlsm

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

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

كل الشكر والتقدير نحتاج لمثل هذه الافكار حبذا لو تمت مشاركة نموذج يجمع أفكار كثيره برمجية ليستفيد الجميع أبدأ برفع نموذج به أفكار للمعادلات المحاسبية معادلات حسابية.mdb وهذا نموذج آخر من تصميمى لمهندسى الالكترونيات لقراءة المقاومة قراءة المقاومة.mdb

تم معالجة الأمر Sub Sum_With_Blank() Dim LR%, t%, m%, k% With Sheets("Sheet2") LR = .Range("j" & Rows.Count).End(xlUp).Row k = 5 For t = 5 To LR + 2 If Application.CountA(.Cells(t, "J") _ .Resize(, 3)) = 0 Then With .Cells(t, "J").Offset(1) .Formula = "=SUM(J" & k & ":L" & t & ")" .Value = IIf(.Value = 0, _ vbNullString, .Value) .Value = .Value End With t = t + 2 k = t + 1 End If Next End With End Sub Ahnad_Sh.xlsm

التجربة اللي عملتها هي: ضبطت برنامج واحد واستخدمت 0.25 ثانيه للإنتظار ، ثم عملت منه 4 نسخ j1 و j2 و j3 و j4 ، ونضعهم مع البرنامج الاصل 1282.1.InvoiceSale_6_FE.accdb في نفس المجلد: . عملت دالتين في هذه الوحدة النمطية في البرنامج الاصل 1282.1.InvoiceSale_6_FE.accdb ، وجعلت اسماء المتغيرات في رأس الوحدة النمطية ، حتى تكون متوفرة للبرنامج كاملا ، حتى اغلاقه : Option Compare Database Option Explicit Dim oAccess1 As Access.Application Dim oAccess2 As Access.Application Dim oAccess3 As Access.Application Dim oAccess4 As Access.Application Dim db1 As String: Dim db2 As String Dim db3 As String: Dim db4 As String ' Public Function Open_Other_DBs() db1 = Application.CurrentProject.Path & "\j1.accdb" db2 = Application.CurrentProject.Path & "\j1.accdb" db3 = Application.CurrentProject.Path & "\j3.accdb" db4 = Application.CurrentProject.Path & "\j4.accdb" ' Dim oAccess As Object Set oAccess1 = CreateObject("Access.Application") 'Create a new Access instance With oAccess1 .OpenCurrentDatabase db1 'Open the specified db .Visible = True 'Ensure it is visible to the end-user .UserControl = True .DoCmd.OpenForm "InvoiceHT_F" 'Open a form? End With Set oAccess2 = CreateObject("Access.Application") 'Create a new Access instance With oAccess2 .OpenCurrentDatabase db1 'Open the specified db .Visible = True 'Ensure it is visible to the end-user .UserControl = True .DoCmd.OpenForm "InvoiceHT_F" 'Open a form? End With Set oAccess3 = CreateObject("Access.Application") 'Create a new Access instance With oAccess3 .OpenCurrentDatabase db1 'Open the specified db .Visible = True 'Ensure it is visible to the end-user .UserControl = True .DoCmd.OpenForm "InvoiceHT_F" 'Open a form? End With Set oAccess4 = CreateObject("Access.Application") 'Create a new Access instance With oAccess4 .OpenCurrentDatabase db1 'Open the specified db .Visible = True 'Ensure it is visible to the end-user .UserControl = True .DoCmd.OpenForm "InvoiceHT_F" 'Open a form? End With End Function Public Function Click_Other_DBs() oAccess1.Forms![InvoiceHT_F].New_Click oAccess2.Forms![InvoiceHT_F].New_Click oAccess3.Forms![InvoiceHT_F].New_Click oAccess4.Forms![InvoiceHT_F].New_Click End Function . وناديتهم كالتالي: . الدالة Open_Other_DBs مرة واحدة تفتح البرامج الاربعة ، هكذا : . . وبما ان المتغيرات موجودة في رأس الوحدة النمطية ، فيمكننا التحكم بالبرامج الاربعة مفتوحة ، يعني عندنا 4 مستخدمين ، الآن نستخدم الدالة Click_Other_DBs ، والتي تنقر على زر "جديد" للبرامج الاربعه في نفس الجزء من الثانية ، يعني المستخدمين الاربعة يدخلون سجل جديد في نفس الجزء من الثانية ، يعني مافي مزاح في الموضوع 😁 ولما اشوف الايقونه ترمش ، اعطي الامر مرة اخرى للدالة Click_Other_DBs ، وهكذا ، والحمدلله النتائج صحيحة 🙂 واكون فاتح الجداول ، واشوف ان الارقام الحمدلله مافيها تكرار ، ولا تعطي البرامج الاربعة اي خطأ عن وجود تكرار 🙂 جعفر 1281.1.zip

بمجرد أن يكون اليوم أكبر من أو يساوي 12 غالبا تنتهي مشاكل التاريخ بسبب الخلط بين اليوم والشهر متأثرا بتنسيق نظام التشغيل. ولكن إذا قل اليوم عن 12 وهو القيمة الكبرى للشهور تبدأ أحيانا مشاكل الخلط وبالتالي اختلاف قيمة التاريخ وخصوصا إذا كتب التاريخ على شكل نص وحصره بعلامتي الرقم #. طريقتي في الاحتراز: تحويل التاريخ إلى رقم باستخدام أربع دوال كالتالي: - إذا كان التاريخ بدون وقت يمكن استخدام دالة CLng. - إذا كان التاريخ يحتوي على وقت ينصح باستخدام دالة CDbl. - إذا كان التاريخ على شكل نص مثل #10/04/2020# وهذا أخطرها ينصح باستخدام دالة DateSerial ليصبح DateSerial(2020, 4, 10). - وإذا كان على شكل نص ويحتوي على وقت مثل #10/4/2020 11:43:30 PM# ينصح بإضافة دالة TimeSerial ليصبح DateSerial(2020, 4, 10) + TimeSerial(23, 43, 30). قد يستثقلها المبرمج ويرى فيها تعقيدا ولكن كاحتراز فهي مطلوبة بشدة وخصوصا إذا كانت البرامج لها علاقة بحسابات وأمور يترتب علي أخطائها أضرارا. هذا اجتهادي وقد أكون صائبا وقد أكون مخطئا.

السلام عليكم اقدم لكم هذا النموذج البسيط لكنه يحتوي على عدة افكار وهي : 1- حقل البحث بجزء من الاسم ويمكن البحث اما في حقل الاسم او حقل المدرسة 2- زر امر يسمح بتعديل الاسم او تجميده وزر امر آخر لحقل المدرسة . زر اضافة سجل جديد الى النموذج الفرعي . ارجو ان ينال اعجابكم Database1.mdb

ادة مهمة لا غنى عنها تحويل الحروف والارقام الى الترميز العالمى UNICODE وذلك لكتابة الرسائل داخل المحرر منعا لمشاكل اللغة العربية نهائيا والعكس طبعا لقرائتها كرة أخرى Converter Arabic and Unicode (v. 2).mdb

للعلم وللامانة الكود منقول من احد المواقع الاجنبية صادفتة من قبل ولما بحثت وتوصلت اليه نقلت دون تجربة بالنسبة لى التجربة من خلال موديول سيئة جدا جدا التطبيق بيهنج ويتجمد لا اهلم ان كان هناك عند اساتذتنا الافاضل حل لتلك المشكلة راى استخدام الكود مباشرة افضل

شكرا لك ربنا يوفقك وييسر امرك

حل احترافى ورائع لكم جزيل الشكر والتقدير

بسم الله ماشاء الله ربنا يزيدك من فضله

شكرا ابا جودي موفق🌹 تحياتي

اكتب الرقم فقط (4 Characters) الكود اللازم Option Explicit Private Sub TextBox1_Change() Dim Ws As Worksheet Dim Lr% Dim My_val Dim F_rg As Range Set Ws = Sheets("Sheet_1") Lr = Ws.Cells(Rows.Count, 1).End(3).Row Ws.Range("A3:N" & Lr).Interior.ColorIndex = xlNone If Len(TextBox1) > 8 Then TextBox1 = "": Exit Sub If Len(TextBox1) = 4 Then My_val = "CIN-" & TextBox1.Text TextBox1.Text = My_val Set F_rg = Ws.Range("A2:A" & Lr).Find(My_val, lookat:=1) '+++++++++++++++++++++++++++ If F_rg Is Nothing Then Ws.Range("A3").Select MsgBox "I Can't Find The Value:" & Chr(10) & Chr(10) & _ """" & My_val & """" Else With Ws.Range("A" & F_rg.Row) .Select .Resize(, 14).Interior.ColorIndex = 35 End With End If End If End Sub الكلف مرفق abou_kasem_text_box.xlsm

هذا الروتين يكتب داخل الموديول Public Function AllowKeyCode(KeyCode As Integer, Shift As Integer) As Integer Select Case KeyCode Case 70 And Shift = 2 AllowKeyCode = KeyCode MsgBox ("turning off ctrl+f") Case 72 And Shift = 2 AllowKeyCode = KeyCode MsgBox ("turning off ctrl+h") Case Else AllowKeyCode = 0 End Select End Function ويتم استدعاء الامر فى زوايا التطبيق من خلال الكود الاتى KeyCode = AllowKeyCode(KeyCode, Shift) فى حدث KeyDown اما لاحد العناصر على النموذج او KeyDown للنموذج نفسه اعتذر تم الرد بتسرع دون الوقوف على الية عند تنفيذ الروتين الخاص بالكود ... وتم حل المشكلة

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

اخي الفاضل ahsnko عنوانك مخالف : اصحاب الخبره : ( ترحيل بيانات حقل غير منضم الى جدول خاص به ) قسم الأكسيس Access Access هذا المنتدى مخصص لمشاركات الأكسيس قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة و بصفة خاصة نؤكدعلى ما يلي 1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة 2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد. 3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال. 4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا..... 5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم. ومخالفة ذلك تعرض الموضوع للحذف رجاء مراعاة هذه القوانين في المستقبل 🙂 جعفر

استاذ اباجودي 🙂 انت سألت وحصلت اجابات على جميع اسالتك ، وبأمثلة 🙂 الى هنا وانتهى الموضوع 🙂 فأتى الدور ان أسأل انا واستفيد من كلمة قالها اخوي ابو ابراهيم سابقا ، ولم التفت لها حينها ، فسألته ، و رده كان على سؤالي 🙂 فقمت انت بالاستفسار عن هذه الجزئية الجديدة من رد اخوي ابو ابراهيم ، والجواب كان انه يستعمل الاستعلام العادي (والذي قد تكون فيه علاقة بين الجداول) كمصدر بيانات للنموذج ، اي انه لا يستعمل الجداول كمصدر بيانات للنموذج ، وهي نفس الطريقة التي استعملها انا 🙂 يعني سؤالي نوعا ما ، خارج عن موضوعك 😁 جعفر

لعل هذا ما ريده mohd322.xlsx

اخي القاضي ، شكرا جزيلا على جميل كلماتك ، ونسأل الله القبول 🙂 جعفر

محمد حسن المحمد جزاكم الله خيرا

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

لا أعلم اذا كان هذا ماتريد Jabalawi.xlsx

معذرة اخوي ابو ابراهيم : نعم بهذه الطريقة يمكن اخفاء الاستعلام ، كما تم اخفاء الجداول ، ولكن ، هل سيكون تنفيذ الاستعلام اسرع في جعله في قاعدة البيانات الخلفية ، مما لو وضعناه في قاعدة بيانات الواجهه ؟ جعفر

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

Try This file adel1.xlsx

حبيبنا الأساذ شحادة، أريد أن أقترح عليك فكرة (تخريج الحديث) من خلال الكتب الستة فقط، على أن يكون مرحلة أولى، لتكون نواة لتخريج موسع للحديث. وتكون طريقة التخريج حسب الاختيار: (الكتاب، الباب، رقم الحديث) أو (رقم الحديث) فقط، وكل من الصورتين مطلوب.

كل الشكر والتقدير لحضرتك ...

ملف نموذج.xlsm

تم التعديل خطوات التعديل : 1- التعديل على السطر : Me.DayZero = -1 * Weekday(MyGrDate) ليصبح : Me.DayZero = -1 * Weekday(MyGrDate) + 1 2- التعديل على مسميات الايام : احد /اثنين / ثلاثاء ... الخ ( تعديل الارقام داخل التسمية ) UmAlQuraUp.rar

قام اباجودي بوضع المثال هنا

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

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

هناك طريقتين: 1. اذا كانت الاسطر في الصورة متساوية ، ويمكن عمل المربع حول السطر ، وهذا المربع ينزل بعدد معين لكل سطر ، فيمكن تحريكه برمجيا / مثلا : نضبط المربع على السطر الاول ، ثم ننزله بالاسهم (Arrow keys down) الى ان يحتوي السطر الثاني (مثلا ضغطنا على السهم الاسفل 6 مرات) ، فيجب ان نضغط 6 مرات اخرى حتى نحتوي السطر الثالث ، وهكذا (ولكن وللأسف الاسطر في الصورة غير متساوية ، فلا يمكن استعمال هذه الطريقة ، 2. ان نعمل جدول خاص ، نكتب فيه رقم السطر (المثال على السطر 15) ، ونكتب قيمة TOP المربع ، نضع التقرير في وضع التصميم ، ثم نحركة بواسطة الاسهم ، ولما يحتوي المربع السطر ، نكتب رقم السطر وقيمة TOP ، وهنا يمكننا استخدام هذه الطريقة : . وهذه نتيجة الضغظ على "رقم التسجيل" 4 (للعلم ، جربت اللون الاصفر ولا يبرز ، فاستعملت اللون الاحمر) : . ولأن الصورة في قسم Page Header ، فيجب ان نعمل حدث "عند التنسيق" به : . و الكود في التقرير يأخذ قيمة TOP رقم التسجيل من الجدول ، ثم نضرب الرقم (رقمي بالبوصة * 1440 ، بينما لو كان رقمك بالسنتيمتر فيكون * 567 ) : Private Sub PageHeaderSection_Format(Cancel As Integer, FormatCount As Integer) Dim rpt_Top As Double Dim rpt_Name As String Dim myWhere As String rpt_Top = DLookup("[rTop]", "tbl_rpt_Rows", "rRow=" & rpt_Row) Me.Box5.Top = rpt_Top * 1440 End Sub . ونكون قد ارسلنا "رقم السجل" من النموذج الفرعي الى المتغير rpt_Row رقم سطر التسجيل : Private Sub أمر180_Click() 'Call MENUFORMS1991 Dim rpt_Name As String Dim myWhere As String rpt_Row = Me.[رقم التسجيل] rpt_Name = "تقرير1" myWhere = "" DoCmd.OpenReport rpt_Name, acViewPreview, , myWhere End Sub . جعفر 1298.سجل.accdb.zip

1-كالعادة تسمية الورقة باللغة الأجنبية 2- اكنب في Texbox ما تـريد 3-اضغط أحد المفاتيح Enter , Tab , Any arrows Code Option Explicit Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim Ws As Worksheet Dim Lr% Dim My_val Dim F_rg As Range Set Ws = Sheets("Sheet_1") Lr = Ws.Cells(Rows.Count, 1).End(3).Row Ws.Range("A3:N" & Lr).Interior.ColorIndex = xlNone Select Case KeyCode Case 37 To 40, 13 My_val = TextBox1.Text Case Else Exit Sub End Select Set F_rg = Ws.Range("A2:A" & Lr).Find(My_val, lookat:=1) If F_rg Is Nothing Then Ws.Range("A3").Select Else With Ws.Range("A" & F_rg.Row) .Select .Resize(, 14).Interior.ColorIndex = 35 End With End If End Sub Flle Icluded abou_kasem.xlsm

اعرف ان استاذى الجليل الاستاذ @husamwahab ما قصر بطرح الحل ووضعه على اكمل وجه ولكن كان قصدى ارفاق القاعدة له فوائد جمه 1- يسهل عليك انت شخصيا معرفة الحل بالاطلاع على التغيرات الجديدة 2- يسهل على من يريد مساعدتك فهم طلبك بوضوح والتكيف اولا مع آلية التصميم والتعامل بعد ذلك معه بوضع الحل المناسب بالآلية التى تتماشى معه

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

لمعرفة ماذا تعني End(4) جرب هذا الكود Sub What_is_End4() MsgBox Sheets("Sheet1").Range("A1", Range("A1").End(4)).Address End Sub بالنسية الصفحة الثّانية هذا الكود Option Explicit Sub sum_Of_JL_Sh_2() Dim LR%, t%, m% With Sheets("Sheet2") LR = .Range("j" & Rows.Count).End(xlUp).Row For t = 5 To LR .Cells(t, "j") = _ IIf(Application.CountA(.Cells(t, "J") _ .Resize(, 3)) = 1, vbNullString, .Cells(t, "j")) Next m = .Range("j5", Range("j5").End(4)).Rows.Count t = 5 Do While t < LR With .Cells(t, "J").Resize(m, 3) .Cells(m, 1).Offset(2) = _ Application.sum(.Value) End With t = t + m + 3 Loop End With End Sub الملف مرفق My_test.xlsm

شريط الصيغة يعطي القيمة الحقيقية للخلية (بدون ماكياج الذي هو تنسيق الخلايا) لأن تنسيق الخلايا هو فقظ قتاع او (كمّامة ترتديها الخلية) لا تحميها من كورونا الذي هو شريط الصيغة ومهما فعلت لا يمكنك اقتاعه بعدم فضح اسرار الخلية الّا اذا أخفيته فهو مثل نسوان هذه الايام تستطيع الاحتفاظ بالسر حتى أوّل هاتف

طبعا تنشىء الاستعلام في قاعدة البيانات الخلفية.. ثم تشير إلى الاستعلام باسمه كما في الجدول.. إذا كنت تريد عمل استعلام يشير إلى محددات من قيم في حقول النموذج فيمكنك إنشاء جملة الاستعلام مكان اسم الجدول.. Set Me.Recordset=DBDAO.OpenRecordset("SELECT * FROM CUSTOMERS WHERE [CUSTOMER ID]=" & Me.CB_CUSTOMER_ID) في الحالة هذه تستطيع وضع جملة الاستعلام في حدث After_Update للحقل.. أو تعيد تنشيط النموذج باستخدام Me.Requery في نفس الحدث

جيد عاشت ايدك عبد الله قدور

السلام عليكم 🙂 اعتقد بأني توصلت لحل ، وبعد عدة محاولات على الشبكة ، على كمبيوترين 🙂 1. النموذج ، تم حذف الجدول CustomersT من استعلام النموذج : . 2. الكومبوبوكس يقوم بإعطاء قيمة اسم الزبون CustomerName ، 3. تم حذف امر حفظ السجلات من الوحدة النمطية ، لأنها لم تكن على سجل النموذج ، فإنها لا تحفظ السجل المطلوب ، 4. تم استعمال هذا الكود لحفظ الترقيم : Private Sub New_Invoice() On Error GoTo err_New_Invoice Try_Again: If Me.NewRecord Then Me.InvoiceNum = Next_Seq("A") DoCmd.RunCommand acCmdSaveRecord End If Exit_New_Invoice: Exit Sub err_New_Invoice: If Err.Number = 3022 Then Dim PauseTime, Start PauseTime = 0.5 ' Set duration. Start = Timer ' Set start time. Do While Timer < Start + PauseTime DoEvents ' Yield to other processes. Loop Resume Try_Again Else MsgBox Err.Number & vbCrLf & Err.Description End If Resume Exit_New_Invoice End Sub . ولما البرنامج يلاحظ وجود تكرار في الرقم ، فإنه يذهب الى رقم الخطأ (3022 كما ذكره اخونا حسام) ، وهنا ينتظر 0.5 (نصف ثانية ، ويمكنك تقليلها ، وبالتجربة ستعرف الرقم الاصح ، والافضل ان تتركه كما هو) ، ثم يعاود المحاوله في الحصول على ترقيم جديد غير مكرر (وهذا الكود وضعته في حدثين) ، وتم تجربته عدة مرات واثبت جدارته 🙂 البرنامج بعده طازه وطالع من الشبكة ، فلازم تعمل له ربط للجداول قبل تشغيله ، فهو بدون جداول 🙂 جعفر 1282.1.InvoiceSale_6_FE.accdb.zip

معظم الاعضاء يلجؤون للمنتديات لما تواجههم مشكلة في مكان ما ، والبعض الآخر يساعد الباقين ، فلا هذا عنده وقت ، ولا ذاك ، إلا اللي محتاج وعنده مشكلة في المثال اللي تقدمه ، فعلى اساسه تلقاه مستعد يجرب 🙂 جعفر

السلام عليكم ورحمة الله لم ترد علي فقمت بمحاولة وضع ملف في مجلد خاص سميته Essai مع مجلد آخر سميته Photos يحوي صورا مرقمة من 1 إلى ... (تملؤه كما تريد بصور القائمة مسماة برقم ترتيب كل عنصر من القائمة)... أرجو أن أكون قد قدمت بعض المساعدة... وباعتبار أن حجم مجلد الصور كبير قمت برفع الملف على موقع تحميل الملفات ورابط الملف بالأسفل... بن علية حاجي رابط الملف : بحث فوري

أخي الفاضل صالح ما بالكم إخواني إذا طلبت منكم طلب بسيط تهربتم مني ! والله إني لأعجب .. أخبرتك أخي أن تضع بعض البيانات في الملف المرفق لتجربة الكود وسألتك عن الخلايا التي سيتم الترحيل إليها فلم تبالي بسؤالي .. التوضيح يوفر الوقت والجهد ويجعل الموضوع لا يطول حتى يتمكن الأعضاء من مساعدة الجميع أرجو تفهم الأمر بارك الله فيكم أخي إليك الكود التالي على قدر ما فهمت .... Sub TransferDataToClosedWB() Dim WB As Workbook Dim LR_A As Long, LR_B As Long Dim Answer As Long LR_A = IIf(Cells(Rows.Count, 1).End(xlUp).Row = 1, 1, Cells(Rows.Count, 1).End(xlUp).Row) Application.ScreenUpdating = False If Application.WorksheetFunction.CountA(Range("A1:A" & LR_A)) < 1 Then MsgBox "لا يوجد بيانات لترحيلها", vbInformation: Exit Sub ThisWorkbook.Sheets("Sheet1").Range("A3:Q" & LR_A).Copy Set WB = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "اكسل2.xlsx") With WB.Sheets("Sheet1") LR_B = IIf(Cells(Rows.Count, 1).End(xlUp).Row = 1, 1, Cells(Rows.Count, 1).End(xlUp).Row + 1) .Range("A" & LR_B).PasteSpecial xlPasteValues .Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1).Select End With Answer = MsgBox("تم الترحيل بفضل الله" & Chr(10) & "هل تريد مسح البيانات التي تم ترحيلها؟", vbQuestion + vbYesNo) If Answer = vbYes Then ThisWorkbook.Sheets("Sheet1").Range("A3:Q" & LR_A).ClearContents Else: End If WB.Close SaveChanges:=True Application.CutCopyMode = False Application.ScreenUpdating = True End Sub أرجو أن يكون الحل صحيحاً وألا يكون فيه تعقيب لأنه لو به تعقيب فهذا بسبب قصور التوضيح ولك جزيل الشكر على اهتمامك بأمر التوضيح الذي طلبته منك Transfer Data To Closed Workbook YasserKhalil.rar

تفضل اخى الكريم ملف للأستاذ / عادل حنفى تحياتى صوت مع الاكسل.rar