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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ربما هدا طلبك . تقسيم البيانات كل اسبوع في ورقة مستقلة مع انشاء مجلد في القرص (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

لا يا أخي @ابو عبد الرحمن اشرف العكس .. 🙂 الذي سيظهر للمستخدمين هو ملف النماذج فقط .. أما ملف الجداول سيكون بعيد عن أعين المستخدمين .. فقط ستحتاجه أنت كمصمم البرنامج لربط نسخة النماذج ( الواجهات ) بنسخة الجداول .. هذا سؤال خارج عن موضوعنا هنا 🙂 إرجع للموضوع الأصلي .. أو إفتح موضوع جديد 🙂

السلام عليكم و رحمة الله و بركاته اصدقائي الاكارم تحية طيبة في هذا التطبيق سنقوم بتحويل قاعدة بيانات اكسس الى SQL Server طبعا قد يعتبر البعض الموضوع قديم نوعا ما و لكن في هذا التطبيق تم التجريب على ويندوز 11 و اوفيس 2021 32بت و SQL 2005 نسخة مخصصة للعمل على ويندوز 11 قبل البدء لا ننسى ان نقوم باخذ نسخة احتياطية من قاعدة بيانات اكسس و اضافة المكتبات الموضحة في الصورة الى قاعدة البيانات ملاحظة : مكتبة microsoft office 16 object library موجودة في المسار "C:\Program Files (x86) \ Microsoft Office \ root \ vfs \ ProgramFilesCommonX86 \ Microsoft Shared \ OFFICE16\MSO.dll" برنامج SQL Server برنامج إدارة قواعد بيانات SQL برنامج ترحيل قواعد بيانات اكسس الى SQL Server الجزء الاول.pdf 1.bmp

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

استاذ موسى @Moosak...الظاهر ان القاعدة على اكثر من جهاز

طريقة الاستدعاء مكتوبة في الكود نفسه أخي أمين 🙂 : 'to call the Function 'To Hijri التاريخ الهجري 'txtMonthNameHijri =MnthName(txtDate,"HJ") 'To Arabic التاريخ بالعربي 'txtMonthNameArabic =MnthName(txtDate,"Ar") 'To English الإنجليزي 'txtMonthNameEnglish =MnthName(txtDate,"En") 'To English Short الإنجليزي المختصر 'txtMonthNameEnglish =MnthName(txtDate,"EnShrt") 'To Coptic القبطي 'txtMonthNameCoptic =MnthName(txtDate,"Cpti") 'To Syriac السرياني 'txtMonthNameSyriac =MnthName(txtDate,"Syr")

حقول غير منضم =حقل اليوم والساعه Me. A, Me. B, Me. C Me. Today= Me. A& "/" & Me. B& "/" & Me. C for Time Me. TA, Me. TB, Me. TC Me. TextTime= Me. TA & ": " & Me. TB & " : " & Me.TC for Sum * جمع كان وقت او يوم Me. A = Me. A + Me. sum هجري او ميلادي غلط Where! Format Today d, m, yyyy

ويمكنك أيضا استخدام عملية الجمع العادية بشرط تحويل الدقائق إلى أيام Private Sub CMPO1_AfterUpdate() Me.txtAA = Me.txtA + Me.CMPO1 / 1440 '/60/24 End Sub

يمكنك استخدام دالة myMod بدلا من استخدام دالة IIf لفحص المدخلات. Function myMod(Number As Double, Divisor As Double) As Double If Divisor <> 0 Then myMod = Number - Divisor * Int(Number / Divisor) End If End Function Sub Test() Dim Time1 As Date Dim Time2 As Date Time1 = TimeSerial(23, 0, 0) Time2 = TimeSerial(7, 0, 0) Debug.Print myMod((Time2 - Time1) * 24, 24) End Sub

جرب (File) ثم (Option) ثم (Current DataBase) ثم آخر اختيار تحت زود العداد لأقصى قيمة زود 4 اصفار باليمين .

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

مرحبامبك ... جمعنا لك الحسنين .... عدل حسب اختيارك واكمل التقرير بما يخدمك .... وان اشكل عليك شيئ اطرح سؤالك بارك الله فيك طبعا يجب عمل نموذج لفتح التقرير لسبب وهو لتحديد الشهر ..... اما الان فهو محدد بالشهر الاول فقط .... hafez-1.accdb

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

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

أخي @ابو عبد الرحمن اشرف بالعكس .. المجلد المشترك في الشبكة يكون فيه ملف الجداول .. أو ال Back End .. أما الملف الذي ستوزعه على المستخدمين هو ملف الواجهات ( النماذج والتقارير والاستعلامات والأكواد والماكرو ) وهذه صورة مختصرة توضح الآلية .. :

الدالة Mid وصيغتها Mid ( text, start_position, [number_of_characters] ) تقوم بقراءة النص وتبدأ من start_position بعدد الأرقام التي وضعناها number_of_characters مثلا الشقة 1350 ..تبدأ بالقراءة من ثالث رقم وهو 5 ..وبعدد 2 .. أي انها تأخذ ثالث رقم ورابع رقم وهو 50 فحينما نعمل جملة في الاستعلام : IIf(Mid([flatNo];3;2)="00";1;0) كاننا نقول ..اذا اخر رقمين = 00.. فأعمل الحقل =1 وفي المعيار نجعله لا يساوي واحد حتى يظهر لنا بقية الشقق التي لاتنتهي ب 00 لوكنت اعرف اعمل فيديو بذلك لعملته ... ان لم تفهم ما أقوله ..فسأعيده بصيغة أخرى

اكتب دالة : =TODAY() ثم كلك يمين وعدل على تنسيق الخلية format cell ثم تخصيص custom وعدل على راحتك

أخي العزيز / ASD101960 الفكرة التي طلبتها موجودة بالمف المرفق بشرط أن تكون المعلومات ( الأسماء ) كما ذكرت في طلبك تبدأ من العمود (A) ومهما كان عدد الصفوف ، ولا يوجد مشكلة إن كانت البيانات تبدأ من عمود آخر يمكن تعديل ذلك بالكود بالسطر السادس اسفل عنوان الكود بالجملة Cells(i, 1) قم بتغيير الرقم 1 إلى رقم العمود الذي تبدأ به البيانات ، وطبعاً تستطيع نسخ الكود وتطبيقه على ملفك بسهولة بالطريقة المعروفة والتي سبق شرحها في الكثير من المشاركات في المنتدى . تقبل تحياتي . أبو عبدالله INSERT_ROW_DOWN_EVERY_NON_BLANK_ROW.rar

نفس الشي وما صارت عندي أي مشكلة ..

عملت على نفس الدالة ..ولم تتوقف عند 10000 هل القاعدة تعمل على اكثر من جهاز؟ ان كانت كذلك والدالة في حدث الحالي فأحتمالية تكرار الرقم كبير