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

قم بنسخ الأداة إلى مجلد C:\WINDOWS\SysWOW64 ثم افتح Command Prompt كمسؤول وقم بتسجيل الأداة regsvr32 RotateLabelVer2.ocx والآن يمكنك في برنامج إضافة الأداة ستظهر الأداة بهذا الاسم: يمكنك تعديل نوع الخط والحجم واللون من صندوق الخصائص RotateLabelVer2.zip

^_^ سبقتني لكن احب ان اضيف مشاركه مع اخي @Foksh تفضل هل هذا ما تريد 1234.rar ولتعم الفائدة وتضويح ما تم تم استخدام هذا الكود Sub GetInfo1() Dim db As DAO.Database Dim rst As DAO.Recordset Set db = CurrentDb Set rst = db.OpenRecordset("Sale_Reg", dbOpenDynaset) With rst .AddNew ![Sale_code] = DLookup("code", "main_itemn", "code=" & "Sale_code") ![Sale_Number] = 1 ![Sale_invoice] = Forms![Sale]![Invoice_Number] ![SSale_Price] = DLookup("Slae_price", "main_itemn", "code=" & "Sale_code") ![Sale_Date] = DLookup("Reg_Date", "main_itemn", "code=" & "Sale_code") ![Sale_Item_Name] = DLookup("item", "main_itemn", "code=" & "Sale_code") ![frosh_date] = Date ![scompany_name] = DLookup("company_name", "qry1", "code=" & "Sale_code") .Update .Close End With Set rst = Nothing db.Close Set db = Nothing End Sub مع ان هناك حلول اخري لكن وجدت الاسهل والاسرع للحلول دون تغير (او فرض راي) على المبرمج

Private Sub CommandButton1_Click() Dim lr As Long Dim ws As Worksheet: Set ws = Sheet8 Application.ScreenUpdating = False lr = ws.Cells(Rows.Count, 5).End(xlUp).Row lr = lr + 1 ws.Cells(lr, 5) = Me.TextBox1.Value ws.Cells(lr, 6) = Me.TextBox2.Value ws.Cells(lr, 7) = Me.TextBox3.Value ws.Cells(lr, 8) = Me.TextBox4.Value ws.Cells(lr, 9) = Me.TextBox5.Value ws.Cells(lr, 10) = Me.TextBox6.Value ws.Cells(lr, 11) = Me.TextBox7.Value ws.Cells(lr, 12) = Me.TextBox8.Value ws.Cells(lr, 13) = Me.TextBox9.Value ws.Cells(lr, 14) = Me.TextBox10.Value ws.Cells(lr, 15) = Me.TextBox11.Value ws.Cells(lr, 16) = Me.TextBox12.Value ws.Cells(lr, 17) = Me.TextBox13.Value For i = 1 To 13 Controls("textbox" & i).Text = "" Next i Application.ScreenUpdating = True End Sub او Private Sub CommandButton1_Click() Dim lr As Long Dim ws As Worksheet: Set ws = Sheet8 Application.ScreenUpdating = False lr = ws.Range("E" & Rows.Count).End(xlUp).Row With ws .Cells(lr + 1, "E").Value = Me.TextBox1.Value .Cells(lr + 1, "F").Value = Me.TextBox2.Value .Cells(lr + 1, "G").Value = Me.TextBox3.Value .Cells(lr + 1, "H").Value = Me.TextBox4.Value .Cells(lr + 1, "I").Value = Me.TextBox5.Value .Cells(lr + 1, "J").Value = Me.TextBox6.Value .Cells(lr + 1, "K").Value = Me.TextBox7.Value .Cells(lr + 1, "L").Value = Me.TextBox8.Value .Cells(lr + 1, "M").Value = Me.TextBox9.Value .Cells(lr + 1, "N").Value = Me.TextBox10.Value .Cells(lr + 1, "O").Value = Me.TextBox11.Value .Cells(lr + 1, "P").Value = Me.TextBox12.Value .Cells(lr + 1, "Q").Value = Me.TextBox13.Value End With For i = 1 To 13 Controls("textbox" & i).Text = "" Next i Application.ScreenUpdating = True End Sub

رزة1 (2).xlsm

controller@ free ppl.xlsm

وعليكم السلام ربما Sub test() Dim a Dim i& a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1) Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbRed End If Next End With End Sub أو Sub tes2() Dim a Dim i& With CreateObject("scripting.dictionary") For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, "" Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbYellow End If Next End With End Sub مع المحافظة على لون الخلية عند تغيير القيمة

Private Sub Worksheet_Change(ByVal Target As Range) Set a = Range("F2:F" & [F65000].End(xlUp).Row) Set b = Range("I2:I" & [I65000].End(xlUp).Row + 10) Set rng1 = CreateObject("Scripting.Dictionary") Set rng2 = CreateObject("Scripting.Dictionary") If Target.Column <> 6 And Target.Column <> 9 Then Exit Sub For Each J In a rng1(J.Value) = J.Value Next J For Each J In b rng2(J.Value) = J.Value If Not rng1.exists(J.Value) And rng2(J.Value) <> "" Then J.Interior.ColorIndex = 36 If rng1.exists(J.Value) Or rng2(J.Value) = "" Then J.Interior.ColorIndex = xlNone Next J End Sub test.xlsb

أهلا بالجميع.. الحقيقة أن الزملاء قاموا بعمل جبار في تطويع أكسس للإنجاز الفكرة.. بارك الله في الجهود.. تحقيق طريقة HTML مع أكسس أرى أن فيها صعوبة! ولم أجرب فعل ذلك.. لكن استخدام محتوى HTML في أكسس، فذلك ممكن... Pattern_Keypad_ADB.zip

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

للتوضيح عند وقف On Error Resume Next يظهر خطأ عند حذف الملف Kill aFile الخطأ run time error 70 You tried to open a write-protected file for sequential Output or Append لقد حاولت فتح ملف محمي ضد الكتابة للإخراج المتسلسل أو الإلحاق بالتوفيق

السلام عليكم والله فعلًا الامر غريب انا جربت الموضوع بنفسى ومش لاقى تفسير إلا أنى لاحظت ان قاعدة المعلومات المطلوب تعديلها كانت معمولة بأكسس 2007 وانا قمت بالتعديل على برنامج أوفيس 2019 فوجدت تماما كلام الاستاذ Foksh مظبوط ولكن عندما جربت النسخة الاولى قبل التعديل التى ارسلها الاستاذ ehab125 وجدتها على نفس المنوال وليس الموضوع ناتجًا عن تعديلى ولكن انا اظن ان هذا يحدث نتيجة التعديل على البرامج من اصدار اقل لإصدار أعلى فالعلم عند الله

هل هذا طلبك ؟؟ 1234.accdb لا تنسى ، اذا انتهت المشكلة ولله الحمد ، فقط اختر الإجابة كأفضل إجابة

ما فيش داعي لتكرار النموذج ، فقط اسم مربع النص اللي هتستخدميه للتاريخ زي الـ ( A )

ان شاء الله بهذا الكود تكتمل الحل Public Function UpdateMyFil() Dim rs As Recordset Dim foundFirstRecord As Boolean Set rs = CurrentDb.OpenRecordset("TempStatmentAcc") foundFirstRecord = False Do While Not rs.EOF If rs("myfrq") < 0 And Not foundFirstRecord Then rs.Edit rs("MyFil") = rs("myfrq") rs.Update foundFirstRecord = True Else If foundFirstRecord Then rs.Edit rs("MyFil") = rs("CR") * -1 rs.Update End If End If rs.MoveNext Loop rs.Close End Function طبعا ال هيحمل الملف المرفق السابق لازم يضيف حقل جديد فى الجدول باسم MyFil

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

انا طبقتها على الجدول .. كود تجريبي صغير ينفذ الفكرة اعلاه .. يمكن تطويره GeneralTest2.rar

أخي الكريم @2saad يبدو أن حضرتك لم تنتبه لتعديل مشاركتي بوضع كلمة val قبل قيمة مربع النص لتحويلها إلى رقم بالتوفيق

انا مش عارفه اشكرك ازاي والله ميرسي جدا لحضرتك وجزاك الله كل خير

ارفق ملف ليتم العمل عليه اخي الكريم ,

بجد بجد شكرا جدا انا تعبتك معايا تسلم حضرتك من كل سوء ليا سؤال بس عند حضرتك لو حبيت اشغل نفس الكليندر فى فورم تانى هل فى تعديلات اعملها

وعليكم السلام والرحمة ربما Sub test() Dim a, w, x, k Dim i&, ii& a = Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 5 To UBound(a) If Not .exists(a(i, 9)) Then .Add a(i, 9), Array(a(i, 9), a(i, 2), a(i, 3) & "\" & a(i, 4), "SP" & a(i, 5) & " PORT " & Format(a(i, 6), "0#"), "TB Number " & Format(a(i, 7), "0#")) Else w = .Item(a(i, 9)) x = Split(w(3), "-") If UBound(x) > 0 Then w(3) = x(0) & "- " & Format(a(i, 6), "0#") .Item(a(i, 9)) = w Else x(UBound(x)) = x(UBound(x)) & " -" & Format(a(i, 6), "0#") w(3) = Join(x) .Item(a(i, 9)) = w End If: End If Next For Each k In .keys Cells(5 + ii, 13).Resize(5) = Application.Transpose(.Item(k)) ii = ii + 6 Next End With End Sub

وعليكم السلام ورحمة الله وبركاته الاستعلام شغال 100% الا ان كنت لم افهم عنك انظر الصورة من استعلامك .. فقط انا غيرت في التواريخ

يمكنك إضافة هذا الكود في حدث الخروج من جميع مربعات النصوص وهذا كود مربع النص الأول كمثال Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim ws As Worksheet Set ws = Worksheets("ملف التقييم صف رابع نصف العام") If Val(Me.TextBox1.Value) > ws.Cells(10, 5).Value Then MsgBox "يجب أن تكون الدرحة أقل من أو تساوي " & ws.Cells(10, 5).Value Me.TextBox1.Value = "" Cancel = True End If End Sub وهكذا مع باقي مربعات النصوص textbox لاحظ رقم العمود 5 سيتغير ورقم التيكست بوكس 1 سيتغير أما 10 فهو رقم الصف الذي به النهاية العظمى للمادة بالتوفيق

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

صدقاً معك حق اخوي الغالي.. هذا دليل واضح على عدم التركيز أثناء العمل والتعامل مع أجهزة الآيفون في الصيانة ههههههه جزاك الله خيراً ، بالفعل هذه المشاركة ، ويا حبذا لو تم تعديل الرابط من الإخوة لتلافي إضاعة الوقت.

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

وعليكم اسلام @عبد الله قدور الغلط في القطعة التالية من الشفرة ' تمرير قيم المعلمات .Parameters.Append .CreateParameter("@Param1", adInteger, adParamInput, , 123) .Parameters.Append .CreateParameter("@Param2", adVarChar, adParamInput, 50, "SampleValue") .Parameters.Append .CreateParameter("@Param3", adDate, adParamInput, , Date) عند إنشاء المحدد لا يجب أن يقترن بالمعامل (@). هذا الإقتران يكون عند إنشاء الإجراء فقط.. قم بإزالة المعامل فقط ' تمرير قيم المعلمات .Parameters.Append .CreateParameter("Param1", adInteger, adParamInput, , 123) .Parameters.Append .CreateParameter("Param2", adVarChar, adParamInput, 50, "SampleValue") .Parameters.Append .CreateParameter("Param3", adDate, adParamInput, , Date) إذا أردت اعطاء المحددات قيمة جديدة لا تقم بإنشاءها مرة أخري.. فقط مرر القيم الجديدة بالطرية التالية Param1.Value=Id Param2.Value=Name Param3.Value=Date ComObj.Parametrs.Refresh

ادا كنت تقصد تعديل بيانات اسم الصنف والكمية فقط تفضل جرب بعد استدعاء البيانات بشرط رقم الفاتورة برنامج المستودع 5 (1).xlsb

جزاكم الله خبرا بتقول انت تعبت في عمل الاكواد ومش عايز واحد ياخد اي كود طيب ممكن تكتب كود واحد من تصميمك هنا ولا تم اخد الاكواد من المنتديات وتطويعها لك وخايف حد يشوف انك اخدتها منهم ... مجرد سؤال عايزين العلم ينتشر الله يرحم والديك ووالدينا

وعليكم السلام ورحمة الله تعالى وبركاته اثراءا للموضوع وبعد ادن الاستاد الكبير @ياسر خليل أبو البراء تفضل اخي يمكنك الابحار كما تشاء داخل مجلداتك وتعبئة جميع الملفات الموجودة داخل الفولدرات على الليست بوكس وفتحها مباشرة عند الظغط اليك الرابط التالي للمعاينة https://streamable.com/uv6f29 ملاحظة : لقد جعلت الكود افتراضي على الفولدرات الموجودة في نفس مسار الملف يمكنك تعديلها على حسب احتياجاتك داخل الكود التالي Private Sub UserForm_Initialize() ' مسار وجود الملف myPatch = Application.ThisWorkbook.Path ' قم بتحديد القرص الخاص بك 'myPatch = "D:\" Set MH = CreateObject("Scripting.FileSystemObject") Set dossier = MH.GetFolder(myPatch) Me.ListBox1.Clear: Me.ListBox2.Clear: Me.ListBox3.Clear Me.ListBox4.Clear: Me.ListBox5.Clear: Me.ListBox6.Clear n = 0 For Each d In dossier.SubFolders Me.ListBox1.AddItem d.Name Me.ListBox1.List(n, 1) = dossier.Path n = n + 1 Next Me.TextBox1 = dossier.Path listefichiers dossier.Path End Sub تعبئة الليست ياسماء الفولدرات 2.xlsm

اخي انت واضع شرط انه لو قيمة الخلية قيمتها اصغر من 0 تظهر كلمة NEED PRODUCTION والخلية تتضمن -2 عادي =IF(E11>0, "There is stock", IF(E11<0, "NEED PRODUCTION", "critical no stock"))

تفضل اخي يمكنك اختيار ما يناسبك Option Explicit ' الغاء فلترة جميع اوراق العمل Sub Sup_tous_les_filtres() Dim WS As Worksheet For Each WS In Worksheets If WS.AutoFilterMode = True Then Debug.Print WS.Name WS.AutoFilterMode = False End If Next End Sub '**********او*********** Sub Sup_tous_les_filtres2() Dim WS As Worksheet For Each WS In Worksheets If WS.AutoFilterMode Then WS.AutoFilter.Range.AutoFilter End If Next End Sub '********تحديد تسلسل معين *********** Sub vSup_tous_les_filtres3() Dim i As Long Dim compteur As Long ' عدد اوراق العمل compteur = 100 ' من ورقة 1 الى 100 For i = 1 To compteur On Error Resume Next If Sheets(i).AutoFilterMode Then Sheets(i).AutoFilter.Range.AutoFilter On Error GoTo 0 End If Next i End Sub

أول خطوة في الوصول لمعلومة تفيدك في مطلوبك هي استعمال محرك البحث الخاص بالمنتدى وتطبيق ما تعلمته من هذه المواضيع ربما تفيدك هذه الروابط https://www.officena.net/ib/search/?q=التصدير الاكسس&quick=1&type=forums_topic&nodes=135&updated_after=any&sortby=relevancy&search_and_or=and بالتوفيق

هذه محاولة في الوصول للحل تعتمد على تقسيم الاسم إلى الاسم ثنائي وثلاثي ورباعي تم وضع معادلاتها يمكنك وضع معادلات العمود B والمقارنة بأربع مستويات بدالة match مثلا أولها تطابق الاسمين في العمود A & B وفي حالة الخطأ تتم المقارنة بين عمودين الاسم الرباعي وفي حالة الخطأ تتم المقارنة بين عمودين الاسم الثلاثي واعتمادا على نتيجة المقارنة تكتب الحالة بالتوفيق نموذج طلب مقارنة.xlsx

الاصدقاء الاكارم تحية طيبة هذا الموضوع هو تطوير للمشاركة التالية وقبل ان ابدا اريد التوجه بالشكر لاخينا السيد جمال السيد فهو من دفعني الى البحث لتطوير هذا الكود وانا هنا لا اقصد التقليل من اهمية الكود الذي طرحه اخينا جمال بالعكس هذا الموضوع هو تطوير للفكرة طرح اخينا جمال وحدتين نمطيتين للاتصال بقاعدة بيانات SQL ولكن كلا الوحديتن فيهما نقاط ضعف الوحدة النمطية الاولى '//Name : AttachDSNLessTable '//Purpose : Create a linked table to SQL Server without using a DSN '//Parameters '// stLocalTableName: Name of the table that you are creating in the current database '// stRemoteTableName: Name of the table that you are linking to on the SQL Server database '// stServer: Name of the SQL Server that you are linking to '// stDatabase: Name of the SQL Server database that you are linking to '// stUsername: Name of the SQL Server user who can connect to SQL Server, leave blank to use a Trusted Connection '// stPassword: SQL Server user password Function AttachDSNLessTable(stLocalTableName As String, stRemoteTableName As String, stServer As String, stDatabase As String, Optional stUsername As String, Optional stPassword As String) On Error GoTo AttachDSNLessTable_Err Dim td As TableDef Dim stConnect As String For Each td In CurrentDb.TableDefs If td.Name = stLocalTableName Then CurrentDb.TableDefs.Delete stLocalTableName End If Next If Len(stUsername) = 0 Then '//Use trusted authentication if stUsername is not supplied. stConnect = "ODBC;DRIVER=SQL Server;SERVER=" & stServer & ";DATABASE=" & stDatabase & ";Trusted_Connection=Yes" Else '//WARNING: This will save the username and the password with the linked table information. stConnect = "ODBC;DRIVER=SQL Server;SERVER=" & stServer & ";DATABASE=" & stDatabase & ";UID=" & stUsername & ";PWD=" & stPassword End If Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stRemoteTableName, stConnect) CurrentDb.TableDefs.Append td AttachDSNLessTable = True Exit Function AttachDSNLessTable_Err: AttachDSNLessTable = False MsgBox "AttachDSNLessTable encountered an unexpected error: " & Err.Description End Function وفى حدث عند فتح النموذج ستضيف الكود التالى Private Sub Form_Open(Cancel As Integer) If CreateDSNConnection("(اسم السرفر )", "اسم قاعدة البيانات ", "اسم المستخدم ", "كلمة السر ") Then '// All is okay. Else '// Not okay. End If End Sub نقطة الضعف هنا انه يجب عليك تكرار الكود لكل جدول و بالتالي كل جدول = سطر برمجي ماذا لو نسي المستخدم جدولا ما !!!!!! الوحدة النمطية الثانية '//Name : CreateDSNConnection '//Purpose : Create a DSN to link tables to SQL Server '//Parameters '// stServer: Name of SQL Server that you are linking to '// stDatabase: Name of the SQL Server database that you are linking to '// stUsername: Name of the SQL Server user who can connect to SQL Server, leave blank to use a Trusted Connection '// stPassword: SQL Server user password Function CreateDSNConnection(stServer As String, stDatabase As String, Optional stUsername As String, Optional stPassword As String) As Boolean On Error GoTo CreateDSNConnection_Err Dim stConnect As String If Len(stUsername) = 0 Then '//Use trusted authentication if stUsername is not supplied. stConnect = "Description=myDSN" & vbCr & "SERVER=" & stServer & vbCr & "DATABASE=" & stDatabase & vbCr & "Trusted_Connection=Yes" Else stConnect = "Description=myDSN" & vbCr & "SERVER=" & stServer & vbCr & "DATABASE=" & stDatabase & vbCr End If DBEngine.RegisterDatabase "myDSN", "SQL Server", True, stConnect '// Add error checking. CreateDSNConnection = True Exit Function CreateDSNConnection_Err: CreateDSNConnection = False MsgBox "CreateDSNConnection encountered an unexpected error: " & Err.Description End Function هذه الوحدة النمطية تقوم بانشاء اتصال DSN وتسجيله في الويندوز لكننا ما زلنا بحاجة الى اضافة الجداول يدويا نعود الى الوحدة النمطية الاولى لانها افضل و اسهل في التعامل توفر قاعدة بيانات SQL جدولا اسمه INFORMATION_SCHEMA.TABLES ( في الاصدار 2005 وما فوق اما في اصدار 2000 لا اعلم اذا كان موجودا ) هذا الجدول يحتوي على اسماء الجداول الموجودة في قاعدة بيانات SQL الفكرة الآن نقوم باستيراد هذا الجدول و نستخرج اسماء الجداول منه و ننفذ حلقة دورانية للارتباط بكافة الجداول On Error GoTo ErrSub Dim DB As Database Dim Rs As Recordset2 Dim TblName As String 'استيراد الجدول الذي يحتوي اسماء الجداول في قاعدة بيانات SQL المحددة '//DoCmd.TransferDatabase acImport, "ODBC Database", "ODBC;Driver={SQL Server};Server=اسم السيرفر;Database=اسم قاعدة البيانات;Trusted_Connection=Yes", acTable, "INFORMATION_SCHEMA.TABLES", "INFORMATION_SCHEMA_TABLES" ' استيراد الجدول الى قاعدة البيانات DoCmd.TransferDatabase acImport, "ODBC Database", "ODBC;Driver={SQL Server};Server=HP-PC\SQLEXPRESS;Database=data1;Trusted_Connection=Yes", acTable, "INFORMATION_SCHEMA.TABLES", "INFORMATION_SCHEMA_TABLES" Set DB = CurrentDb ' فتح الجدول Set Rs = DB.OpenRecordset("INFORMATION_SCHEMA_TABLES", dbOpenTable) ' فتح الجدول ' الذهاب الى السجل الاول Rs.MoveFirst ' حلقة دورانية تتوقف عند الوصول الى السجل الاخير في الجدول السابق Do While Rs.EOF = False ' استخراج اسماء الجداول من الحقل الثاني في الجدول و تخزينها في المتغير TblName = Rs.Fields(2) ' استدعاء الوحدة النمطية للارتباط بالجدول '//Call AttachDSNLessTable(TblName, TblName, "اسم قاعدة البيانات", "اسم السيرفر", "", "") Call AttachDSNLessTable(TblName, TblName, "HP-PC\SQLEXPRESS", "data1", "", "") ' الذهاب الى السجل التالي Rs.MoveNext Loop ' اغلاق الجدول Rs.Close ' حذف الجدول بعد الانتهاء من الارتباط DoCmd.DeleteObject acTable, "INFORMATION_SCHEMA_TABLES" MsgBox "تم استيراد كافة الجداول بنجاح", vbInformation ErrSub: If Err.Number <> 0 Then MsgBox Err.Number & vbCrLf & Err.Description End If Import All Table From Sql DataBase.rar

أما إذا أردت عدم التقيد بخلية محددة وأن يظهر التاريخ حيثما وضعت الـ CheckBox فجرب المرفق التالي CheckBox.rar

وعليكم السلام كود تصدير البيانات دفعة واحدة خاص بالاصدارة 2010 يمكنك التعديل حسب الاصدار الذي عندك Here are a few examples for inserting all the data at once: strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=z:\docs\test.accdb" ''Late binding, so no reference is needed Set cn = CreateObject("ADODB.Connection") cn.Open strCon ''Create a table called ATable scn = "[Excel 8.0;HDR=YES;DATABASE= & ActiveWorkbook.FullName & ]" strSQL = "SELECT * INTO ATable " _ & "FROM " & scn & ".[sheet7$A1:C4]" ''Execute the statement cn.Execute strSQL ''Insert into a table called ATable scn = "[Excel 8.0;HDR=YES;DATABASE= & ActiveWorkbook.FullName & ]" strSQL = "INSERT INTO ATable " _ & "SELECT * FROM " & scn & ".[sheet7$A1:C4]" ''Execute the statement cn.Execute strSQL ''Insert into a table with no column header in Excel, ''the fields are [afield],[atext],[another] scn = "[Excel 8.0;HDR=NO;DATABASE= & ActiveWorkbook.FullName & ]" strSQL = "INSERT INTO ATable ([afield],[atext],[another]) " _ & "SELECT F1 As afield, F2 As AText, F3 As another FROM " _ & scn & ".[sheet7$A1:C4]" ''Execute the statement cn.Execute strSQL منقول ،،،،