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

Public Function AddAmount(originalAmount As Double) As Double Select Case originalAmount Case Is <= 50 AddAmount = 75 Case 51 To 100 AddAmount = 100 Case 101 To 150 AddAmount = 125 Case Else AddAmount = 0 End Select End Function في الاستعلام يمكن الاستدعاء هكذا: NewAmount: AddAmount([OriginalAmount]) لان الاضافات غير متطابقة يمكن تعديل الوحدة بما يناسبك :: تحياتي

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت قد إستوعبت طلبك بشكل صحيح فربما هدا سيوفي بالغرض ملاحظة : الملف يتضمن عدة أكواد يجب وضع كل كود في مكانه المناسب في Module1 ضع الأكواد التالية Const a As String = "الرئيسية" Const b As String = "تقرير بالموقع" Const c As String = "تقرير بالمنتج" Public Property Get WS() As Worksheet Set WS = Sheets(a) End Property Public Property Get dest() As Worksheet Set dest = Sheets(b) End Property Public Property Get dest2() As Worksheet Set dest2 = Sheets(c) End Property Sub Run_MainFilter() Call FilterData("J", dest, dest.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub Sub Run_SecondaryFilter() Call FilterData("D", dest2, dest2.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub ' دالة لفلترة البيانات Private Sub FilterData(srcColumn As String, srsWS As Worksheet, Clé As Range) Dim arr() As Variant, dataRange As Range, lastRow As Long Dim Crite As String, ColArr As Long, N As Long, lastCol As Long Crite = Clé.Value lastRow = WS.Cells(WS.Rows.Count, srcColumn).End(xlUp).Row If WS.Range(srcColumn & "3:" & srcColumn & lastRow).Find(Crite, _ LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then MsgBox Crite & " غير موجود", vbExclamation Exit Sub End If Application.ScreenUpdating = False srsWS.Range("A5:J" & srsWS.Rows.Count).ClearContents arr = WS.Range("A3:K" & WS.Cells(WS.Rows.Count, "I").End(xlUp).Row).Value N = 5 For ColArr = 1 To UBound(arr, 1) If arr(ColArr, WS.Range(srcColumn & "1").Column) = Crite Then srsWS.Cells(N, 1).Resize(1, 10).Value _ = Application.Index(arr, ColArr, Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11)) N = N + 1 End If Next ColArr lastCol = srsWS.Cells(5, srsWS.Columns.Count).End(xlToLeft).Column lastRow = srsWS.Cells(srsWS.Rows.Count, "A").End(xlUp).Row srsWS.PageSetup.PrintArea = srsWS.Range("A1", srsWS.Cells(lastRow, lastCol)).Address Application.ScreenUpdating = True End Sub ' تعبئة القائمة المنسدلة تقرير المنتج Sub AddDropdown_Main() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Main" Set destCell = dest.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "P").End(xlUp).Row Set Data = WS.Range("P2:P" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تعبئة القائمة المنسدلة تفرير بالموقع Sub AddDropdown_Secondary() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Secondary" Set destCell = dest2.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "O").End(xlUp).Row Set Data = WS.Range("O2:O" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تسطير البيانات Sub ApplyBorders(wsTarget As Worksheet) Dim lastRow As Long, rng As Range lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub Application.ScreenUpdating = False wsTarget.Range("A5:J100").Borders.LineStyle = xlNone Set rng = wsTarget.Range("A5:J" & lastRow) With rng.Borders .LineStyle = xlContinuous .Color = RGB(0, 0, 0) .Weight = xlThin End With Application.ScreenUpdating = True End Sub وفي حدث ورقة الرئيسية Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim tmp As Object, item As Range, OnRng As Range, ColArr As Range Dim LastRow As Long Application.ScreenUpdating = False If Not Intersect(Target, Me.Columns("D")) Is Nothing Or _ Not Intersect(Target, Me.Columns("J")) Is Nothing Then If Not Intersect(Target, Me.Columns("D")) Is Nothing Then Set ColArr = Me.Range("D3", Me.Cells(Me.Rows.Count, "D").End(xlUp)) Set OnRng = Me.Range("O2:O65000") Else Set ColArr = Me.Range("J3", Me.Cells(Me.Rows.Count, "J").End(xlUp)) Set OnRng = Me.Range("P2:P65000") End If Set tmp = CreateObject("Scripting.Dictionary") For Each item In ColArr If item.Value <> "" Then tmp(item.Value) = "" Next item OnRng.ClearContents If tmp.Count > 0 Then OnRng.Resize(tmp.Count, 1).Value = Application.Transpose(tmp.Keys) End If End If Application.ScreenUpdating = True End Sub في حدث ورقة تقرير بالموقع Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Secondary End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم الموقع ", vbCritical: Exit Sub Call Run_SecondaryFilter End If End Sub وفي حدث ورقة تقرير بالمنتج Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Main End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم المنتج ", vbCritical: Exit Sub Call Run_MainFilter End If End Sub وأخيرا في موديول جديد الكود الخاص بحفظ الملفات بصيغة PDF Option Explicit Sub SaveRangeAsPDF() Dim WSdest As Worksheet, sFile As String, folderName As String, sPath As String Dim lastRow As Long, lastCol As Long, pdfPath As String Set WSdest = ActiveSheet sFile = WSdest.Name folderName = "ملفات PDF" sPath = ThisWorkbook.Path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath On Error GoTo 0 lastRow = WSdest.Cells(WSdest.Rows.Count, "A").End(xlUp).Row lastCol = WSdest.Cells(5, WSdest.Columns.Count).End(xlToLeft).Column WSdest.PageSetup.PrintArea = WSdest.Range("A1", WSdest.Cells(lastRow, lastCol)).Address With WSdest.PageSetup .Orientation = xlLandscape .PaperSize = xlPaperA4 .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With pdfPath = sPath & sFile & ".pdf" WSdest.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub بالتوفيق ............ جرد المنتج_V2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Public Property Get WS() As Worksheet Set WS = Sheets("PTT") End Property Public Property Get dest() As Worksheet Set dest = Sheets("Round 5") End Property Private Sub CommandButton1_Click() Dim r As Long, s As Long, t As Long, tmp As Long, ID As String, n As Boolean If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then MsgBox "لا يوجد أي إيصالات للطباعة على قاعدة البيانات ", vbExclamation Exit Sub End If On Error Resume Next For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt WS.[d4] = ID WS.[U2] = ID Err.Clear WS.PrintOut If Err.Number <> 0 Then MsgBox "تم إلغاء طباعة الإيصالات", vbExclamation Exit Sub End If Cnt: Next r WS.[aa1] = s WS.[aa2] = t Unload Me End Sub '===================================== Private Sub CommandButton2_Click() Dim r As Long, tmp As Long, s As Long, t As Long, FolderName As String Dim filePath As String, ID As String, n As Boolean, pdfFolder As String If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then: MsgBox "لا يوجد أي إيصالات للحفظ على قاعدة البيانات ", vbExclamation: Exit Sub FolderName = "الإيصالات" pdfFolder = ThisWorkbook.Path & "\" & FolderName If Dir(pdfFolder, vbDirectory) = "" Then On Error Resume Next MkDir pdfFolder If Err.Number <> 0 Then: Exit Sub On Error GoTo 0 End If For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt End If WS.[d4] = ID: WS.[U2] = ID filePath = pdfFolder & "\invoice_" & ID & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cnt: Next r MsgBox "تم تصدير الملفات إلى مجلد: " & FolderName, vbInformation Unload Me End Sub PTT 2024 v2.xlsm

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

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

السلام عليكم و رحمة الله صراحة لم اطلع على الملف الثانى ارجو ان يكون هذا الكود التالى هو المقصود ملحوظة : قم بانشاء ورقة جديدة سمها Colln Sub Collection() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, LS As Long Set ws = Sheets("Colln") LR = ws.Range("F" & Rows.Count).End(3).Row For Each Sh In Worksheets(Array("أدب عربي1", _ "أدب عربي2", "أدب عربي3", "أدب عربي4")) LS = Sh.Range("F" & Rows.Count).End(3).Row Sh.Range("A1:I" & LS).Copy ws.Range("A" & LR).PasteSpecial xlPasteAll LR = LR + LS Next Application.CutCopyMode = False End Sub

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

لو تعرف احكيلي علشان نلاقي حد يساعدنا

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

لا يتم تكرار الأرقام .. فالكود يعيد ترقيم حقل ال ID تصاعديا كل مرة ..

وعليكم السلام ورحمة الله تعالى وبركاته دالة IF تحتاج إلى شروط واضحة وتنتظر تحديد ما يجب أن يتم في حال كان الشرط صحيحا أو خطأفي حالتك IF "" غير مكتمل لأنك لم تحدد ما يجب تنفيذه في حال كانت الشروط فارغة أو صحيحة إذا كنت تحاول استخدام دالة IF مع FILTER لتحديد قيمة فارغة مثلا عند عدم وجود نتائج في FILTER فيمكنك استخدام دالة IFERROR =IFERROR(FILTER(AP4:AT353, ISNUMBER(SEARCH(AF6, AQ4:AQ353))), "") مع التأكد من أن الفواصل في الصيغة تتناسب مع الاصدار الموجود لديك ; او ,

احسن انه في تناقض في كلامك ..... كيف برنامجك ترقيم غير مكرر وانت تتعمد اضافة سجل برقم مكرر ولا تريد رسالة الخطأ ....!!!!!!!!!! ؟؟؟؟؟ اضف السجل بدون اضافة رقم والبرنامج هو المسؤل عن الترقيم .... ثم يعيد ترتيب الارقام حسب تسلسل التاريخ ....... جرب ملفي بالطريقة التي ذكرتها لك دون ان تسجل او تغير الرقم الظاهر في مربع النص ....

1️⃣ فيما يخص التبويب Print Options :- الأجزاء المظللة باللون الأصفر ( Top , Bottom , Left , Right ) : وظيفتها التحكم بهوامش الصفحة المراد طباعتها . الأجزاء المظللة باللون الأزرق ( Print Data Only ) : يتم طباعة البيانات فقط دون تنسيقات أو إضافات ( مثل الخطوط ، العناوين ، أو النصوص الثابتة ) . الأجزاء المظللة باللون الأخضر ( Print Form Only ، Print Datasheet Only ) : * Print Form Only : لطباعة جزء النموذج فقط . * Print Datasheet Only : لطباعة جزء الجدول أو ورقة البيانات فقط . باختصار هذا الخيار مخصص للنماذج المنقسمة (Split Form) ، حيث يمكن طباعة عرض واحد فقط من النموذج 2️⃣ أما التبويب Columns :- الأجزاء المظللة باللون الأخضر Grid Settings تتيح لك التحكم بعدد الأعمدة المطبوعة في الورقة . على سبيل المثال كما في ( الكتيبات أو التقارير المصفوفة ) ◀ Number of Columns ( عدد الأعمدة ) :- يحدد عدد الأعمدة التي يتم تقسيم الصفحة إليها عند الطباعة . القيمة الافتراضية هي 1 ، ويمكنك زيادتها لطباعة البيانات في عدة أعمدة ( مثل طباعة قائمة عناوين ) . ◀ Row Spacing ( تباعد الصفوف ) :- يحدد المسافة بين كل صف والصف الذي يليه داخل العمود نفسه . يتم قياسه بوحدات القياس المستخدمة ( عادة بالبوصة أو السنتيمتر ) . ◀ Column Spacing ( تباعد الأعمدة ) :- يحدد المسافة بين الأعمدة . يستخدم عند تعيين أكثر من عمود لضمان وجود فراغات مناسبة بينها . الأجزاء المظللة باللون البنفسجي Column Size : ◀ Width ( العرض ) :- يحدد عرض كل عمود . وهو ما قد يؤثر على حجم البيانات المعروضة في العمود . ◀ Height ( الإرتفاع ) :- يحدد ارتفاع العمود . يستخدم لتحديد مساحة القيمة المعروضة داخل العمود. ◀ Same as Detail ( مطابق للتفاصيل ) :- عند تفعيل هذا الخيار ، يتم ضبط أبعاد الأعمدة ( العرض و الارتفاع ) بحيث تكون متطابقة مع تفاصيل التقرير (التخطيط التفصيلي).الأجزاء في اللون البنفسجي ، تسمح لك بالتحكم بعرض وارتفاع المود الواحد في الورقة أو التقرير . وهنا ليس هناك اي قيم محددة بل هي حسب حاجتك . الأجزاء المظللة باللون البرتقالي Column Layout : ◀ Down , then Across ( الإتجاه من الأعلى للأسفل ، ثم عبر الأعمدة ) : حيث يتم ملء البيانات من الأعلى إلى الأسفل في العمود الأول ، ثم ينتقل إلى العمود التالي . ◀ Across , then Down (عبر الأعمدة أولاً ، ثم الإتجاه من الأعلى للأسفل ) : حيث يتم ملء البيانات في الصف الأول من كل الأعمدة ، ثم ينتقل إلى الصف التالي . يعني باختصار شديد هذا التبويب مفيد عند إنشاء تقارير تحتاج إلى تنسيق متعدد الأعمدة ، مثل طباعة بطاقات الأسماء أو قوائم ... إلخ أما فيما يخص مشكلتك مع الأرقام ، فهي باعتقادي تختلف ولن يستطيع أحد معرفة مقاسات وطبيعة تصميم تقاريرك غيرك ؛ فبعد تجربتك المتكررة من التعديل على هذه الارقام ( حسب حاجتك طبعاً ) ستتوصل الى ارقام صحيحة تناسب تصميم تقريرك أو ما تريد طباعته .

أخي الكريم اهلاً وسهلاً بك معنا .. من وجهة نظري اعتقد أن اعدادات الطباعة قد تختلف بحسب التقرير الذي تريد طباعته ، فعادةً اكسيس يقوم بانشاء تقرير مع افتراض حجم الورق = Letter كما في الصورة أدناه ، في النقطة 2 . وحتى أنه يفترض اتجاه الورقة = بشكل طولي كما في النقطة 1 . أيضاً يقوم باختيار الطابعة الإفتراضية بشكل تلقائي للتقارير كما في النقطة 3 ,, وعليه فإنه وحسب حاجتك في تقريرك ( اختيار اتجاه الورقة = " طولي " أو " عرضي " ) وحجم الورقة = A4 أو A3 ... إلخ . وتحديد الطابعة لكل تقرير . فمثلاً لو كان التقرير هذا يطبع ملصق باركود مثلاً ويوجد طابعة لهذا النوع من الملصقات فيتم اختيارها لهذا التقرير . وإذا كنت في تقرير آخر تريد طباعة معلومات بحجم الورقة العادية = A4 فتختار نوع الطابعة لهذا التقرير بشكل منفصل . وطبعاً هنا في هذه النقطة سيكون الأمر أكثر توسعاً من مجرد اختيار طابعة لكل تقرير دون تحديد اسمها في كود الطباعة ( إن لم تخني معلومتي ) هذا بالنسبة لما تفضلت به في استفسارك .. والله اعلم هي فقط وجهة نظر

وبار ك فيكم شكرا لك اخ حسونة والاخ أبو مروان

يمكنك دمج الطريقتين مع بعض كما في الصورة ListBox1.ColumnCount = 12-V3.xlsm

مشاركة مع الاخوة ..... انظر هذا .... ADD (1).accdb

جرب هدا بعد تنفيد ما سبق دكره سابقا Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub المصنف 4.xlsb

أخي @عذاب الزمان بعد الاطلاع على مرفقك وجدت أنك معتمد على حقل ال ID بشكل أساسي .. لذلك غيرت المنهجية وعملته لك بشكل يلائم مرفقك .. نفضل : 🙂 ADD.accdb

فى نقطه لازم تكون عارفها اولا يمكن لل PHP الوصول لل Mysql (طبيعيا) (ستطلب معرفة جيده للغة php و css و html) ويمكن للاكسيس الوصول لل mysql ايضا (المحلى) وليس اغلب الاستضافات بسبب الحماية لكن لا يمكن لل php الوصول لقاعدة بيانات اكسيس بالتالى اذا كنت تريد تريد معرفة فكرة لربط الاكسيس مع mysql واستخدام ال php معا يمكن النظر فى هذا الموضوع لكن اذكرك انك بحاجه لكى تفهم لغة php ,css,html واذا وصلت فيهم لمستوي جيد حينها قد تستغني عن الاكسيس تماما والتوجه الى واجهات البرمجه php ف هي عالم اوسع وامكانيته اكبر اتمني ان اكون وضحت لك الافكار واذا كان هناك نقطه لم استوفي الشرح فيها لا تتردد فى سؤالى وان شاء الله اذا كان عندي لك اجابه سوف ارد عليها

لدي فكرة أستخدمتها في عدة برامج .. 🙂👌 إضافة حقل رقمي من نوع Doble مزدوج ونسميه Order مثلا .. وهو حقل خاص بالترتيب ( ترتيب ظهور السجلات ) بحيث يتم ترتيب السجلات بناءا على هذا الحقل.. ويأخذ قيمته تلقائيا بعد إدراج السجل .. ثم بعد ذلك تتغير قيمته حسب موقعه المطلوب بين السجلات .. بحيث تضيف 0.001 مثلا لقيمة السجل المراد أن يكون هذا السجل بعده ليأخذ موقعه المناسب .. وبهذا نستطيع التحكم بترتيب السجلات بدون التأثير على حقل المفتاح الأساسي

السلام عليكم ايضا انا لدي تساؤل ؟؟ كيف تضع الرقم المطلوب داخل النموذج بمعنى : كيف تعرف مرتبة الرقم الذي ستضيفه .. بمعنى اوضح كيف عرفت ان الرقم المناسب هو 9 ؟ ماهي معاييرك ؟ الحل برأيي : ان اعادة الترقيم يكون منفصل عن الادخالات يتم الترقيم التلقائي بناء على التاريخ الذي يتم فرزه من الأقدم الى الأحدث يمكنك اعادة الترقيم في اي وقت سواء ادخلت بيانات ام لم تدخل ADD2.rar

تم الحصول على الكود ولكن يجب الاتصال اولا باستخدام sql driver 17 Sub nel_SQL() Dim db As DAO.Database Dim tdf As DAO.TableDef Set db = CurrentDb For Each tdf In db.TableDefs If tdf.Connect <> "" Then 'tdf.Connect = "PROVIDER=SQLOLEDB;SERVER=WIN-9V6JHD626P3\SQLEXPRESS;DATABASE=tarikbase2;UID=user1001;PWD=1@@1a" tdf.Connect = "ODBC;DRIVER=ODBC Driver 17 for SQL Server;SERVER=.\SQLEXPRESS;UID=user1001;PWD=1@@1a;Trusted_Connection=No;DATABASE=tarikbase2;" 'ODBC;DRIVER=ODBC Driver 17 for SQL Server;SERVER=.\SQLEXPRESS;UID=user1001;PWD=1@@1a;Trusted_Connection=No;DATABASE=tarikbase2; tdf.refreshlink End If Next tdf Set tdf = Nothing Set db = Nothing End Sub