ناقل

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

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

طيب شوف التحايل هذا ....... Dim fso As New FileSystemObject Dim LExcelOriginal As String Dim LExcelCopyOf As String Dim msgstyle If fso.FolderExists(Environ("USERPROFILE") & "\Desktop\" & "\Folder2") Then Else fso.CreateFolder (Environ("USERPROFILE") & "\Desktop\" & "\Folder2") End If DoCmd.RunSavedImportExport "export" LExcelOriginal = "D:\Table1.xlsx" LExcelCopyOf = Environ("USERPROFILE") & "\Desktop\" & "Folder2" & "\" & "Table1.xlsx" FileCopy LExcelOriginal, LExcelCopyOf Kill ("D:\Table1.xlsx") MsgBox Space(20) & "تمت العملية بنجاح.." & Space(20), msgstyle, "للمعلومية" ملفك بد التعديل .... Create Folder2 (1).accdb

استخدم هذا الكود ...... Dim fso As New FileSystemObject If fso.FolderExists(Environ("USERPROFILE") & "\Desktop\" & "\Folder2") Then Else fso.CreateFolder (Environ("USERPROFILE") & "\Desktop\" & "\Folder2") End If 'DoCmd.RunSavedImportExport "export" 'fso.CopyFile Environ("USERPROFILE") & "\Desktop\" & "Folder2\Table1.xlsx", True Output_Path = Environ("USERPROFILE") & "\Desktop\" & "Folder2\Table1.xlsx" DoCmd.TransferSpreadsheet acExport, , "Table1", Output_Path او استخدم هذا ,,,,,, Dim fso As New FileSystemObject If fso.FolderExists(Environ("USERPROFILE") & "\Desktop\" & "\Folder2") Then Else fso.CreateFolder (Environ("USERPROFILE") & "\Desktop\" & "\Folder2") End If DoCmd.TransferSpreadsheet acExport, , "Table1", Environ("USERPROFILE") & "\Desktop\" & "Folder2\Table1.xlsx", True

جرب هذا .... Worker.rar

تفضل .... New folder.rar

تفضل ...... New folder.rar

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

انت سألت هذا سابقا ولم تتفاعل مع الموضوع

ابحث في المنتدى تجد اجابة شافية لسؤالك من قبل الاستاذ @jjafferr

قم بادخال رقم المنتج الذي اشتريته

جرب الشيفرة هذه ..... On Error Resume Next Dim strSQL3, strSQL1, strSQL2 As String Dim B As New Access.Application Set B = CreateObject("Access.Application") B.OpenCurrentDatabase "D:\New folder (2)\Database.accdb" strSQL1 = "CREATE TABLE asrt_tbl " _ & "(Code INTEGER , cosmotic CHAR(50), available BIT , " _ & "supplier CHAR(50),Unit CHAR(30), unitprice Double ,Quantity CHAR(30) , " _ & "CONSTRAINT asrt_tblConstraint UNIQUE " _ & "(Code, cosmotic, available, supplier, Unit, unitprice, Quantity ));" strSQL2 = "CREATE TABLE asrt_tbl1 " _ & "(Code INTEGER , cosmotic CHAR(50), available BIT , " _ & "supplier CHAR(50),Unit CHAR(30), unitprice Double ,Quantity CHAR(30) , " _ & "CONSTRAINT asrt_tblConstraint UNIQUE " _ & "(Code, cosmotic, available, supplier, Unit, unitprice, Quantity ));" strSQL3 = "CREATE TABLE asrt_tbl2 " _ & "(Code INTEGER , cosmotic CHAR(50), available BIT , " _ & "supplier CHAR(50),Unit CHAR(30), unitprice Double ,Quantity CHAR(30) , " _ & "CONSTRAINT asrt_tblConstraint UNIQUE " _ & "(Code, cosmotic, available, supplier, Unit, unitprice, Quantity ));" B.DoCmd.RunSQL strSQL1 B.DoCmd.RunSQL strSQL2 B.DoCmd.RunSQL strSQL3 B.CloseCurrentDatabase Set B = Nothing B.Quit MsgBox Space(20) & "تمت العملية بنجاح.." & Space(20), msgstyle, "للمعلومية"

هل تريدة يحذف ام ماذا ؟؟؟ ما هو الاجراء المطلوب ??

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

حسب طلبك كان هناك شرطان للعد كود الدعوى نوع المستند وفي الجدول المعطى كود الدعوى 1 نوع المستند عقد انظر عند الضغط على الزر في الشرح يكون الناتج 2

هذه يسهل ما تشاء من شروط .... استخدم هذا Dim myCriteria As String myCriteria = "[نوع المستند] = '" & Me.نوع_المستند & "'" myCriteria = myCriteria & " AND " myCriteria = myCriteria & "[كود الدعوي] =" & Me.كود_الدعوي Me.n = DCount("[كود الحركة]", "harka", myCriteria)

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

ممكن ترسلها محولة pdf وتحفظها في حاسوبك

.

تفضل ..... moh.rar وهذا الفلدر به القاعدة المنشأ فيها الجداول .... ضع الفولدر في الدرايف D New folder (2).rar

الان مجرب الكود ويعمل .... انظر الجداول الثلاث تم انشاؤها .... Dim strSQL3, strSQL1, strSQL2 As String Dim B As New Access.Application Set B = CreateObject("Access.Application") B.OpenCurrentDatabase "D:\Database.accdb" strSQL1 = "CREATE TABLE asrt_tbl " _ & "(Code INTEGER , cosmotic CHAR(50), available BIT , " _ & "supplier CHAR(50),Unit CHAR(30), unitprice Double ,Quantity CHAR(30) , " _ & "CONSTRAINT asrt_tblConstraint UNIQUE " _ & "(Code, cosmotic, available, supplier, Unit, unitprice, Quantity ));" strSQL2 = "CREATE TABLE asrt_tbl1 " _ & "(Code INTEGER , cosmotic CHAR(50), available BIT , " _ & "supplier CHAR(50),Unit CHAR(30), unitprice Double ,Quantity CHAR(30) , " _ & "CONSTRAINT asrt_tblConstraint UNIQUE " _ & "(Code, cosmotic, available, supplier, Unit, unitprice, Quantity ));" strSQL3 = "CREATE TABLE asrt_tbl2 " _ & "(Code INTEGER , cosmotic CHAR(50), available BIT , " _ & "supplier CHAR(50),Unit CHAR(30), unitprice Double ,Quantity CHAR(30) , " _ & "CONSTRAINT asrt_tblConstraint UNIQUE " _ & "(Code, cosmotic, available, supplier, Unit, unitprice, Quantity ));" B.DoCmd.RunSQL strSQL1 B.DoCmd.RunSQL strSQL2 B.DoCmd.RunSQL strSQL3 B.CloseCurrentDatabase Set B = Nothing B.Quit

تفضل مع ملاحظة التكرار في استعلام الانشاء ..... Dim strSQL3, strSQL1, strSQL2 As String Dim B As New Access.Application Set B = CreateObject("Access.Application") B.OpenCurrentDatabase "D:\New folder (2)\Database.accdb" strSQL1 = "CREATE TABLE asrt_tbl " _ & "(Code INTEGER , cosmotic CHAR(50), available BIT , " _ & "supplier CHAR(50),Unit CHAR(30), unitprice Double ,Quantity CHAR(30) , " _ & "CONSTRAINT asrt_tblConstraint UNIQUE " _ & "(Code, cosmotic, available, supplier, Unit, unitprice, Quantity ));" strSQL2 = "CREATE TABLE asrt_tbl1 " _ & "(Code INTEGER , cosmotic CHAR(50), available BIT , " _ & "supplier CHAR(50),Unit CHAR(30), unitprice Double ,Quantity CHAR(30) , " _ & "CONSTRAINT asrt_tblConstraint UNIQUE " _ & "(Code, cosmotic, available, supplier, Unit, unitprice, Quantity ));" strSQL3 = "CREATE TABLE asrt_tbl2 " _ & "(Code INTEGER , cosmotic CHAR(50), available BIT , " _ & "supplier CHAR(50),Unit CHAR(30), unitprice Double ,Quantity CHAR(30) , " _ & "CONSTRAINT asrt_tblConstraint UNIQUE " _ & "(Code, cosmotic, available, supplier, Unit, unitprice, Quantity ));" B.DoCmd.RunSQL strSQL1 B.DoCmd.RunSQL strSQL2 B.DoCmd.RunSQL strSQL3

اخي حاولت ان ادمج لك الكودين ولم استطع .... اعذرني ... ولا زالت المحاولات مستمرة ...

استخدم هذا الكود .... DoCmd.TransferDatabase acLink, "Microsoft Access", Me.txtPath, acTable, "MSysObjects", "oo", False If DCount("[Name]", "oo", "[Name] = '" & Me.ObjName & "'") = 1 Then MsgBox "الجدول موجود مسبقا" Else MsgBox "الجدول غير موجود" End If