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

لهدا سبق تدكيرك بضرورة انهاء تصميم ملفك حتى نتمكن من تحديد اسماء الشيتات والنطاقات المرغوب الاشتغال عليها على العموم اخي يمكننا العمل خطوة خطوة للوصول للنتيجة المطلوبة سوف نشتغل على اول شيت وهو ورقة 5 مع ترحيل البيانات الى ورقة 6 . يمكنك بعد دالك نسخ نفس الاكواد مع تغيير اسماء اوراق العمل فقط اول خطوة هتدخل على حدث ورقة 5 وتمسح جميع الاكواد السابقة وتقوم بتعويضها بالتالي تم انشاء كود الترحيل والطباعة مع بعض الاظافات التي من الممكن ان تساعدك على العمل على الملف بشكل افضل بالنسبة للاستدعاء طريقة وضعك للمعادلات بورقة الادخال لن تمكنك من استدعاء البيانات في نفس الموضع يمكنك انشاء ورقة خاصة بدالك او تعويض الصيغ بالاكواد *****ترحيل****** Private Sub cmdadd2_Click() Dim wsdata As Worksheet Dim wsdest As Worksheet Dim Rng1 As Range, Rng2 As Range Set wsdata = ThisWorkbook.Sheets("Sheet5") Set wsdest = ThisWorkbook.Sheets("Sheet6") Dim A, B, C, D, E, F, J, k, L, The_Date, N_invoice, The_Currency As String Set Rng1 = wsdata.Range("A9:G28") Set Rng2 = wsdata.Range("A32,C32,E32") The_Date = Date: N_invoice = wsdata.[F7]: The_Currency = "د" & "." & "إِ." A = wsdata.[A32]: B = wsdata.[A33]: C = wsdata.[A34] D = wsdata.[C32]: E = wsdata.[C33]: F = wsdata.[C34] J = wsdata.[E32]: k = wsdata.[E33]: L = wsdata.[E33] Arr = Array([B9], [C9], [D9], [E9], [F9], [G9], [A32], [C32], [E32]) For i = 0 To 8 If Arr(i) = Empty Then msg = MsgBox("يرجى ملء بيانات" & " " & Arr(i).Offset(-1, 0), vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "Admin") Arr(i).Select Exit Sub End If Next If Not IsNumeric(N_invoice) Or N_invoice = 0 Then MsgBox "المرجوا ادخال رقم الفاتورة", vbExclamation, "Admin": Exit Sub If Application.WorksheetFunction.CountIf(wsdest.Range("C:C"), wsdata.[F7].Value) > 0 Then MsgBox "رقم الفاتورة موجود مسبقا", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin": Exit Sub msg = MsgBox("ترحيل البيانات ؟", vbYesNo + vbQuestion, "Admin") If msg = vbYes Then Application.ScreenUpdating = False col = Rng1 For i = 1 To UBound(col) If Len(col(i, 2)) > 0 Then wsdest.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(1, 17).Value _ = Array(The_Date, N_invoice, (col(i, 2)), (col(i, 3)), (col(i, 4)), (col(i, 5)), (col(i, 6)), The_Currency & (col(i, 7)), A, B, C, D, E, F, J, k, L) On Error Resume Next ' Union(Rng1, Rng2).SpecialCells(xlCellTypeConstants).ClearContents N_invoice.Value = N_invoice.Value + 1 With wsdest.Range("A9:A" & wsdest.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-8") wsdata.[F7].Value = wsdest.Range("C" & Rows.Count).End(xlUp).Value + 1 End With End If Next Call Add_border wsdata.Activate Application.ScreenUpdating = True msg = MsgBox("تم ترحيل البيانات بنجاح", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "Admin") End If End Sub *****فاتورة جديدة****** Private Sub CommandButton1_Click() Dim msg As VbMsgBoxResult Dim MyRng As Range Set wsdata = ThisWorkbook.Sheets("Sheet5") Set MyRng = wsdata.Range("A9:G28") msg = MsgBox("هل انت مناكد من افراغ البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "انتباه") If msg = vbYes Then On Error Resume Next Application.ScreenUpdating = False MyRng.SpecialCells(xlCellTypeConstants).ClearContents wsdata.Range("A32,C32,E32").Value = Empty On Error GoTo 0 End If End Sub Private Sub Worksheet_Activate() Set ws1 = ThisWorkbook.Sheets("Sheet5") Set ws2 = ThisWorkbook.Sheets("Sheet6") Application.ScreenUpdating = False On Error Resume Next If Len(ws2.Range("C9").Value) <> Empty Then ws1.[F7].Value = ws2.Range("C" & Rows.Count).End(xlUp).Value + 1 End If End Sub *****ترقيم عمود (A)****** Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False On Error Resume Next If Not Intersect(Target, Range("B9:B28")) Is Nothing Then Application.EnableEvents = False AddNumbering Application.EnableEvents = True End If On Error GoTo 0 End Sub Private Sub CmdPrint_Click() Print_invoice End Sub وفي module جديد انسخ الاكواد التالية Sub Print_invoice() ' طباعة Dim sh As Worksheet, i As Long Set sh = ActiveSheet If Application.WorksheetFunction.CountA(sh.Range("B9:B28")) = 0 Then msg = MsgBox("ليس هناك بيانات للطباعة", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin") Exit Sub End If For i = 9 To 28 Application.ScreenUpdating = False If Cells(i, 1) = "" And Cells(i, 2) = "" Then Cells(i, 1).EntireRow.Hidden = True End If Next sh.PageSetup.PrintArea = "A1:G35" ActiveWindow.SelectedSheets.PrintOut Range("A9:A28").EntireRow.Hidden = False End Sub Sub AddNumbering() ' ترقيم Dim MyDest As Worksheet: Set MyDest = Sheet5 Dim F As Range, R As Range Set D = MyDest.Range("A9:A28") Set F = MyDest.Range("B9:B28") D.ClearContents For Each R In F If R.Value <> "" Then J = J + 1 R.Offset(0, -1).Value = Format(J, "0") End If Next End Sub Sub Add_border() ' تسطير البيانات Dim rng As Range, cell As Range Dim sh As Worksheet: Set sh = Sheet6 Application.ScreenUpdating = False sh.Activate dl = sh.Range("A:R").Find("*", , , , xlByRows, xlPrevious).Row 'Sh.Range("a9:R" & dl).Borders.LineStyle = xlNone sh.Range("A9:R1000").Borders.LineStyle = xlNone dc = sh.Cells(9, Columns.Count).End(xlToLeft).Column Set rng = sh.Range(Cells(9, 1), sh.Cells(dl, dc)) For Each cell In rng With cell .Borders.Weight = xlThin .Borders.ColorIndex = 5 End With Next cell End Sub شاشة الدخول مع صلاحيات 3.xlsb

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

تفضل مثال ، قم بتعبئة الحقول واضغط حفظ ستلاحظ انه اخذ الرقم التلقائي قبل عملية الحفظ ، ليتحقق من آخر رقم محفوظ في الجدول ويزيد عليه 1 Dmax.accdb

هل تنفع هذه الفكرة testDbNotes.accdb

الغفو اخي يسعدني حقا انني استطعت مساعدتك تفضل لقد تم تصحيح الاكواد الدي قمت باظافتها انت على اخر ملف مرفوع على المنتدى وتفعيلها على ورقة 7 و8 شاشة الدخول مع صلاحيات 4.xlsb

اذا كانت المشكلة في أنه سيقوم شخصين باستخدام نفس النموذج مثلاً لإضافة سجل جديد ( ويترتب عليه استخدام نفس الجدول طبعاً ) ، وكان الترقيم تلقائي في حقل الـ ID عادة ؛ ففي مثل هذه المشاكل كنت اعتمد طريقة أني أجعل الترقيم مستخدماً DMax في حدث زر الحفظ يقوم بإضافة الترقيم لحقل الـ ID أو رقم الفاتورة أو رقم المريض .... الخ في نفس الزر وقبل إجراء عملية الحفظ . هكذا لن يتعارض الترقيم المزدوج أو المكرر مع أمر الحفظ . هذه كفكرة استخدمها عادةً دون الحاجة لأي أكواد ..... إلخ

السلام عليكم لتعم الفائدة ارفق لكم كود يقوم بربط جدول من قاعدة بيانات sql برمجيا قد يحتاج الى ضغط واصلاح حتى يظهر الجدول Database6.accdb

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

تفضل مشاركتي اطلع عليها ترقيم يومي جديد.accdb

تفضل أخي مرفقك بعد التعديل والاضافات ....................... اضغط على سجل جديد وجرب طلباتك . 1-1.accdb

برنامج العقود - 4.accdb

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

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

وعليكم السلام جرب الكود التالي Private Sub UserForm_Initialize() Dim fso As Object, oFolder As Object, sPath As String, i As Long sPath = "D:\" Set fso = CreateObject("Scripting.FileSystemObject") UserForm1.ListBox1.Clear If fso.FolderExists(sPath) Then Set oFolder = fso.GetFolder(sPath) For Each oFolder In oFolder.SubFolders If Left(oFolder.Name, 1) <> "$" Then i = i + 1 UserForm1.ListBox1.AddItem oFolder.Name End If Next oFolder End If Set fso = Nothing End Sub

اشكرك على المرور . اكيد في جزء رابع وحامس ......... حتى النهايه يتضمن ادخال الشيكات كتابة القيود اخاصه بعملية الشراء استعلام شيكات تعديل فواتير مشتريات طباعه فاتوره على طابعه POS طباعه ليبل باركود طباعه كشف حساب الاصناف حسب كمية البيع ان يكون البرنامج كنسخ تجريبيه لمدة 30 يوم البرنامج يرسل نسخه احتياطية الى الايميل من خلال اوتلوك كل نهاية جلسة عمل (منفذه في النسخه الحاليه)

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

آخر صف يتم حسابه على العمود A والصواب العمود B لأن A فارغ يمكنك تغيير هذا السطر lr = .Cells(.Rows.Count, "A").End(xlUp).Row إلى lr = .Cells(.Rows.Count, "B").End(xlUp).Row ولا يقوم الكود بحذف المصدر بالتوفيق

TEST _Formula.xlsx

وعليكم السلام-فين الملف هل يمكن العمل على التخمين ؟!!!

أخي الكريم ، ما تقدم به الأخ @زياد الحسناوي هو نموذج لطلبك ، ولكني أعتقد أنك تظن ان النماذج إن تم إخفائها فهي لن تظهر إلا عن طريق الكود ، وهذا الطلب غير ممكن ، فحماية النماذج ليست من صلاحيات آكسيس ، وإنما آكسيس حريص أكثر على البيانات ؛ والبيانات يتم تخزينها بالجداول - والجداول يمكن إخفائها دون عودة كما في النموذج المرفق أعلاه ، أما النماذج فذلك غير وارد في الآكسس ( هذا من وجهة نظري ) .

استاذ @ناقل المحترم استبدل Utilities.Restart فقط Restart

وانت في صحة وسلامة طيب انشئ وحدة نمطية وضع هذا فيه ::::::: Private Const TIMEOUT = 99 Public Sub Restart() Dim scriptpath As String scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat" If Dir(scriptpath, vbNormal) <> "" Then If DateAdd("s", TIMEOUT * 1, FileDateTime(scriptpath)) < Date Then Kill scriptpath Else Application.Quit acQuitSaveAll Exit Sub End If End If Dim s As String s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf s = s & "SET /a counter=0" & vbCrLf s = s & ":CHECKLOCKFILE" & vbCrLf s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf s = s & "SET /a counter+=1" & vbCrLf s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf s = s & "IF EXIST ""%~f1.%3"" GOTO CHECKLOCKFILE" & vbCrLf s = s & "start "" "" ""%~f1.%2""" & vbCrLf s = s & ":CLEANUP" & vbCrLf s = s & "del %0" Dim intFile As Integer intFile = FreeFile() Open scriptpath For Output As #intFile Print #intFile, s Close #intFile Dim dbname As String, ext As String, lockext As String Dim idx As Integer For idx = Len(CurrentProject.FullName) To 1 Step -1 If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For Next idx dbname = Left(CurrentProject.FullName, idx - 1) ext = Mid(CurrentProject.FullName, idx + 1) If Left(ext, 2) = "ac" Then lockext = "laccdb" Else lockext = "ldb" End If s = """" & scriptpath & """ """ & dbname & """ " & ext & " " & lockext Shell s, vbHide Application.Quit acQuitSaveAll End Sub تحت حدث الزر ضع هذا :::::::: Utilities.Restart

السؤال : اريد أن يطبع رقم صفحة التقرير ادا كان التقرير يحتوي على أكثر من صفحة وأن لا يطبع أي رقم اذا كان التقرير يحتوي على صفحة واحدة فقط هل من الممكن عمل ذلك لأنه في حالة وضع الترقيم على صفحة واحده يكون شكل التقرير غير مقبول . الاجابة للأخ حارث : في مربع النص الذي يعرض أرقام الصفحات اكتب في مصدر عنصر التحكم فيه : =IIf([Pages]>1;"صفحة " & [Page] & " من " & [Pages])