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

تفضل اخي الكريم New Microsoft Excel Worksheet.xlsx.rar

أها لذلك النموذج لم يعمل لأن الجداول غير موجودة 😇

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

يظهر لي نموذج فقط..ليس في القاعدة اي جداول

test-17-05-2023.xlsm

من الخطأ أن يكون نوع حقل الترقيم نصي يجب أن يكون رقمي ويفضل أن يكون من نوع Long Integer على العموم استخدام هذا السطر بعد تعديل طفيف عليه: Me.sMembership_No = Nz(DMax("Val([sMembership_No])", "tbl_name_swimmer"), 6000) + 1 وتأكد من توسيع طول الحقل إذا أردت الإستمرار بنوع نصي.

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

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

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

السلام عليكم قد تكون المشكلة في الإعدادات الإقليمية في الوندوز مرفق صورة لتوضيح طريقة ضبط تنسيق التاريخ في الاعدادات الإقليمية

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

انشاء الله شغال على برنامج لك .. فقط أمهلني . وما يصير خاطرك إلا الطيب .

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ربما هدا طلبك . تقسيم البيانات كل اسبوع في ورقة مستقلة مع انشاء مجلد في القرص (E) وحفظ الملفات بداخله بصيغة (PDF) مع تنسيق الجداول بنفس التنسيق المرفق في طلبك . Public Sub Split_Sheet_condition_of_the_week() Dim dataSheet As Worksheet, weekSheet As Worksheet Dim minDate As Date, maxDate, weekStartDate As Date Dim lr As Long, c As Long, LastRow As Long, MH As Variant Dim weekSheetName As String, WS_Address As String Dim ST_DATA, ST_Name, ST_Path, ST_WS_Data As String Dim WS_Data As Range, Total_Rng As Range Dim wsData As Worksheet: Set wsData = Worksheets("تجميع") 'حدف جميع اوراق العمل باستثناء ورقة التجميع Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "تجميع" Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next Set dataSheet = wsData With dataSheet lr = .Cells(.Rows.Count, "F").End(xlUp).Row 'اصغر تاريخ minDate = Application.WorksheetFunction.Min(.Range("F2:F" & lr)) ' اكبر تاريخ maxDate = Application.WorksheetFunction.Max(.Range("F2:F" & lr)) End With weekStartDate = Date_Prev_Saturday(minDate) While weekStartDate <= maxDate 'تسمية الشيتات weekSheetName = Format(weekStartDate, "d") & " To " & Format(weekStartDate + 6, "d") With ActiveWorkbook Set weekSheet = Nothing On Error Resume Next Set weekSheet = .Worksheets(weekSheetName) On Error GoTo 0 If weekSheet Is Nothing Then 'اظافة وتسمية اوراق العمل Set weekSheet = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count)) weekSheet.Name = weekSheetName weekSheet.DisplayRightToLeft = True Else weekSheet.Cells.Clear End If End With 'فلترة البيانات weekSheet.Range("l1:m1").Value = Array(dataSheet.Range("F1").Value, dataSheet.Range("F1").Value) weekSheet.Range("l2:m2").Value = Array(">=" & CLng(weekStartDate), "<=" & CLng(weekStartDate) + 6) dataSheet.Range("F1:k" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=weekSheet.Range("l1:m2"), CopyToRange:=weekSheet.Range("A4"), Unique:=False weekSheet.Range("l1:m2").Clear weekSheet.Columns("A:F").EntireColumn.ColumnWidth = 16 LastRow = weekSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Set Total_Rng = Range(weekSheet.Cells(LastRow + 1, "A"), weekSheet.Cells(LastRow + 1, "F")) MH = (RGB(153, 153, 255)) ' اظافة المعادلات weekSheet.Range("F5").Formula = "=COUNTIF(تجميع!$f$2:$f$500,a5)" weekSheet.Range("F5").AutoFill Destination:=Range("F5:F" & LastRow) weekSheet.Range("E5:E" & LastRow) = "=sum(B5*D5)" Cells(LastRow + 1, 1).Value = "المجموع" For c = 2 To 6 Cells(LastRow + 1, c).Value = Application.Sum(Range(Cells(5, c), Cells(LastRow, c))) Next c 'تنسيق الجدول Total_Rng.Interior.Color = MH Total_Rng.Font.Bold = True Total_Rng.Font.Size = 13 With Range("A5:F" & LastRow + 1) .HorizontalAlignment = xlCenter .Font.Name = "Calibri" .Font.Size = 16 .Value = .Value End With 'تسطير الجدول DL = weekSheet.Range("A65500").End(xlUp).Row DC = weekSheet.Cells(5, Columns.Count).End(xlToLeft).Column Range(weekSheet.Cells(5, 1), weekSheet.Cells(DL, DC)).Borders.Weight = xlThin 'فواصل الصفحات With weekSheet.Range("A5:A" & _ weekSheet.Range("A" & Rows.Count).End(xlUp).Row) Set WS_Data = weekSheet.Cells.Find(What:="المجموع", LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext) If Not WS_Data Is Nothing Then WS_Address = WS_Data.Address Do If Not WS_Data Is Nothing Then WS_Data.Offset(1).PageBreak = xlPageBreakManual End If Set WS_Data = .FindNext(WS_Data) If WS_Data Is Nothing Then Exit Do End If If WS_Data.Address = WS_Address Then Exit Do End If Loop End If End With On Error Resume Next ActiveWindow.View = xlPageBreakPreview weekSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 ActiveWindow.View = xlNormalView ' إنشاء مجلد الحفظ ST_Name = "فرز البيانات الأسبوعية" ST_DATA = "" ST_WS_Data = "E:\" ' قم بتغييره بما يناسبك 'ST_WS_Data = "D:\" If IsEmpty(ST_Name) Then Exit Sub If IsEmpty(ST_DATA) Then Exit Sub MkDir ST_WS_Data & "\" & ST_Name ST_Path = ST_WS_Data & "\" & ST_Name & "\" & ST_DATA ' مسار وضع الشيتات بصيغة (PDF)""""""""""""""""""""""""""""" مسار مجلد الحفظ weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="E:\فرز البيانات الأسبوعية\" & weekSheet.Name & "_" & Format(Now, "MMMM") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False weekStartDate = weekStartDate + 7 Wend dataSheet.Select MsgBox "" & ST_WS_Data & ST_Name & vbLf & vbLf & vbLf & "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy") & " " & _ FolderName, _ vbInformation, " : تم حفظ الملفات بنجاح في " On Error GoTo 0 Application.ScreenUpdating = True End Sub Private Function Date_Prev_Saturday(fromDate As Date) As Date Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate)) End Function بالتوفيق.......... تجميع V1.xlsm

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

وعليكم السلام - وكيف تنتظر المساعدة من أحد ومحرر الأكواد محمى بكلمة سر ؟!!! وبما ان محرر الأكواد محمى فيمكنك ذلك من خلال اضافة هذا السطر فى كل كود من أكواد التكست بوكس التى تقوم بإدخال التاريخ بها مع مراعاة تغيير اسم التكست بوكس لما متماشى معك , ولكم جزيل الشكر Me.txtBrewDate = Format(CDate(Me.txtBrewDate), "dd/mm/yyyy")

السلام عليكم ورحمة الله وبركاته جمعة مباركة للجميع التعديلات الجديدة : 1ـ عندما تريد تعديل حساب اثناء اختيارك لرقم الحساب تاتيك معطيات هذا الحساب في الفورم لتختار منها ما تريد تعديله 2ـ حساب المتاجرة وارباح وخسائر والميزانية الختامية تم ضمهم في ورقة واحدة وسميت الاغلاق اذا اردت اقفال حساباتك تذهب الى ميزان المراجعة الذي يوجد فيه زر الانتقال اليها ثم ....... في النظر كفاية عن الشرح 3ـ زر جديد في القيود للصق قيمة العملة بمعطيات قيمته بالعملة الرئيسية 4ـ زر لصق فارق الميزان يقوم باحتساب الفرق للعملتين الرئيسية والفرعية 5ـ فورم اضافة التاريخ ( هدية الاخ نزار) للتذكيراسم المستخدم : خبور كلمة المرور : بسم الله كلمة مرور التعديلات : بسم الله وترقبوا قريبا ان شاء الله برنامج خبور بالتاريخ الهجري ودمتم في حفظ الله وسلامته تحياتي وسلامي اخوكم / خبور __________________________.rar