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

السلام عليكم ورحمه الله وبركاته اتفضل اطلع المشاركه التاليه لاخى واستاذى العزيز @kanory جزاه الله عنا كل خير بالتوفيق

السلام عليكم ور حمة الله اكتب المعادلة التالية فى الخلية D4 ثم اسحب نزولا =DATEDIF($A4;$B4;"y") اما المعادلة التالية اكتبها فى الخلية E4 ثم اسحب نزولا =DATEDIF($A4;$B4;"ym") اما المعادلة الاخيرة اكتبها فى اى خلية تشاء =SUM(D4:D7;INT(SUM($E$4:$E$6)/12))&" Years,"& MOD(SUM($E$4:$E$6);12)&" Months,"

احيانا وجود المثال يسهل علينا التطبيق ..... لان الكلام النظري غير التنفيذ ..... على كل حال تفضل هذه الوحدة النمطية كييفها حسب مثالك بارك الله فيك ... Sub FormatExcelOut(FileName As String) Dim i As Integer Set objapp = CreateObject("Excel.Application") objapp.Visible = False Set wb = objapp.Workbooks.Open(FileName, True, False) For Each ws In wb.Worksheets With ws .DisplayRightToLeft = True .Application.DisplayAlerts = False .usedRange.Borders.LineStyle = 1 .Columns.Font.Name = "Arial" .Columns.Font.Size = 12 .Columns.Font.Bold = True .Range("A1:E1").RowHeight = 20 .Tab.Color = 15656192 ' .usedRange.Columns.AutoFit .usedRange.HorizontalAlignment = 3 .usedRange.Columns(1).Interior.Color = vbYellow End With Next wb.Save objapp.Quit Set objapp = Nothing End Sub

Try this code Sub Test_LionHeart() Dim a, b, lr As Long With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row .Range("D2:H" & lr).ClearContents a = CreateNamesArray(.Range("A2:A" & lr), .Range("B2:B" & lr)) ShuffleArray a b = ConvertToColumns(a, lr - 1) .Range("D2").Resize(UBound(b, 1), UBound(b, 2)).Value = b End With End Sub Function CreateNamesArray(ByVal namesRange As Range, ByVal countRange As Range) Dim nameArray, nameIndex As Long, countIndex As Long, rowCount As Long, totalNames As Long, currCount As Long, i As Long rowCount = namesRange.Rows.Count totalNames = WorksheetFunction.Sum(countRange) ReDim nameArray(1 To totalNames, 1 To 1) nameIndex = 1 For countIndex = 1 To rowCount currCount = countRange(countIndex, 1).Value For i = 1 To currCount nameArray(nameIndex, 1) = namesRange(countIndex, 1).Value nameIndex = nameIndex + 1 Next i Next countIndex CreateNamesArray = nameArray End Function Private Sub ShuffleArray(ByRef arr) Dim temp, i As Long, j As Long Randomize For i = LBound(arr) To UBound(arr) j = Int((UBound(arr) - i + 1) * Rnd + i) temp = arr(i, 1) arr(i, 1) = arr(j, 1) arr(j, 1) = temp Next i End Sub Function ConvertToColumns(ByVal inputArray, ByVal divisor As Long) Dim numOutputCols As Long, i As Long, j As Long, k As Long numOutputCols = Application.WorksheetFunction.RoundUp(UBound(inputArray, 1) / divisor, 0) ReDim outputArray(1 To divisor, 1 To numOutputCols) k = 1 For j = 1 To numOutputCols For i = 1 To divisor If k <= UBound(inputArray, 1) Then outputArray(i, j) = inputArray(k, 1) k = k + 1 End If Next i Next j ConvertToColumns = outputArray End Function

وهذه مشاركتي مع الاستاذ @kkhalifa1960 تفضل <><><><><><><><> كتشنة الرقم السرى.accdb

المفروض بدل تكرار كتابة رقم الجلوس والرقم السري في كل مرة ولكل مجموعة أن تكتب بداية رقم الجلوس وبداية الرقم السري وعدد المجموعات ( او عدد المجموعة ) فقط مرة واحدة حيث يقوم البرنامج هو نتحديد رقم المجموعة وتوزيع ارقام الجلوس والارقام السرية لها ... ثم تلقائي ينتقل للمجموعة الثانية ويوزع ارقام الجلوس والارقام السرية دفعة واحدة .. بدون تدخل منك ... الا اذا كانت هناك الية معينة انت تريدها ارجو توضيحها ........

ابحث في المنتدى ............... تجد العديد منها ................ انظر ...... تفضل هنا تابع الموضوع

أخي @حسين العربى استخدم هذا الكود في حدت عند تحميل النموذج If GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("SELECT * FROM Win32_Process where Name ='msaccess.exe'").Count > 1 Then MsgBox ("i can work alone"): DoCmd.Quit acQuitSaveAll

In worksheet module put the code Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim rng As Range Set rng = Range("F9:L13") If Not Intersect(Target, rng) Is Nothing Then Cancel = True Call VBA_Circle_Text Range("K17").Value = CountOvalShapes(rng) End If End Sub Sub VBA_Circle_Text() Dim cel As Range, m As Double, n As Double Set cel = Application.Selection DeleteShapesWithinRange cel With cel m = .Height * 0.1 n = .Width * 0.1 Application.ActiveSheet.Ovals.Add Top:=.Top - m, Left:=.Left - n, Height:=.Height + 2.25 * m, Width:=.Width + 1.75 * n With Application.ActiveSheet.Ovals(ActiveSheet.Ovals.Count) .Interior.ColorIndex = xlNone With .ShapeRange.Line .Weight = 2 .ForeColor.RGB = vbRed End With End With End With cel.Select End Sub Function CountOvalShapes(ByVal rng As Range) As Long Dim shp As Shape, cnt As Long For Each shp In ActiveSheet.Shapes If shp.Type = 1 And Not Intersect(shp.TopLeftCell.MergeArea, rng) Is Nothing Then cnt = cnt + 1 Next shp CountOvalShapes = cnt End Function Sub DeleteShapesWithinRange(ByVal rng As Range) Dim shp As Shape For Each shp In rng.Parent.Shapes If Not Application.Intersect(rng.Parent.Range(shp.TopLeftCell.Offset(1, 1).Address), rng) Is Nothing Then shp.Delete Next shp End Sub

تم حل المشكله في هذا https://www.officena.net/ib/topic/118598-معادلة-جمع-بشروط/?_report=919#comment-715203

وعليكم السلام ورحمة الله وبركاته عدل هذا السطر Application.Match(Val(Target.Value), Columns(1), 0) الى Application.Match(Val(Target.Value), Columns(4), 0)

السلام عليكم و رحمة الله استخدم هذا الكود Sub TranData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, i As Integer, Arr Set ws = Sheets("استلام مبلغ") Set Sh = Sheets("جمع المبالغ") ActiveWindow.SelectedSheets.PrintOut from:=1, to:=1, copies:=1 LR = Sh.Range("C" & Rows.Count).End(3).Row Arr = Array("B7", "B6", "E4", "D6", "A8") For i = LBound(Arr) To UBound(Arr) Sh.Range("B" & LR + 1).Offset(0, i) = ws.Range(Arr(i)) Next End Sub

اذا اردت تشفير قاعدة البيانات بتحويلها من Accdb الى Accde لابد من عمل قاعدتان امامية واخرى خلفية طبعا قاعدة البيانات الخلفية والخاصة بالجداول لابد ان تكون غير مشفرة اى Accdb اما الامامية ان اردت تشفيرها الى Accde لابد من عمل ذلك مرتين 1- على جهاز يحتوى على اوفيس 32 بيت 2- على جهاز يحتوى على اوفيس 64 بيت وتعطى للعميل مع قاعدة الجداول الخلفية القاعدتان الاماميتان والمشفرتان الـقاعـدة الامامية ذات النواة 32x المشفرة ذات الامتداد Accde والقاعدة الامامية ذات النواة 64x المشفرة ذات الامتداد Accde حتى يستخدم القاعدة الامامية التى تتوافق مع نواة الاوفيس لديه او اذا قام العميل فى احد الايام بتغيير الاوفيس بإصدار آخر ونواة مختلفة يعمل بالقاعدة الاخرى او اذا كان العميل يملك اكثر من جهاز وقد تختلف انوية اصدارات الاوفيس من جهاز لاخر

السلام عليكم احبتي الكرام من مواضبع الاستاذه زهره مثال جميل ممكن الاستفاده منه http://arabteam2000-forum.com/index.php?/profile/15367-zahrah/ za_SkinAccess.rar

السلام عليكم ورحمة الله تعالى وبركاته على كل مصممى ومطورى قواعد البيانات ببساطة عند محاولة تشفير قاعدة البيانات الى accDE لابد من إنشاؤها مره باستخدام office (Access) x64 و إنشاؤها مره أخرى باستخدام office (Access) x32 حتى لا تحدث مشكلة عند العملاء بسبب إختلاف أنوية الأوفيس للاسف الشديد . للعلم الموضوع مختص فقط بتشفير القاعدة بالامتداد Accde فقط اى أنه لا علاقة للموضوع بالامتداد Accdb ولا علاقة للموضوع باستخدام دوال API حتى لو تم الاخذ فى الاعتبار عند كتابة الكود مراعاة عمل الكود عند استخدام دوال API على كلتا النواتان 64x , 32 x هذه لقطة من مقال المصدر : >>--> مايكروسوفت لذلك فإن accDE الخاص بـ x32 accDE و x64 خاصان جدًا بحجم النواه والبنية التي تم تجميعهما بها ويجب أن تعمل الأجهزة المستهدفة بنفس حجم النواة لاستعمال accDE الذي تم إنشاؤه باستخدامه ولا توجد استثناءات لهذه القاعدة

الدكتورة زهره تركت في عقول الناس علم ينتفعو به ,, وهذا العمل مستمر الاجر فيه حتى بعد الممات ,, (إذا مات ابنُ آدمَ انقطع عملُه إلا من ثلاثٍ : صدقةٍ جاريةٍ ، وعلمٍ ينتفعُ به ، وولدٍ صالحٍ يدعو له) ... وهيه اصابت العلم الذي ينتفع به الناس,, نسئل الله ان تكون بخير وجازها الله كل الخير .

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

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

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

Me.Table1_subform.SetFocus DoCmd.RunCommand acCmdSelectAllRecords Microsoft Access Database جديد(3).accdb

كل الشكر والامتنان للاستاذ الخبير lionheart على مساعدتي في إنجاز العمل بنجاح. وقد ساعدته قيِّم عطائه ، وعلمه ربنا ييسر امرك ويزيدك من نعيمعه فعلا اكرمتني ربي يكرمك كل الشكر والتقدير والاجلال لك أستاذي

كثرة الامثلة في الردود ... اين مثالك اخي رضوان الذي اعتمدته انت كي ننظر في سؤالك الثاني

نسخة منقحة ومراجعة كثيرا ، إن شاء الله تخلو من الأخطاء. حاولوا بالفأرة تقليل وزيادة عرض النافذة أثناء التشغيل ومراقبة التوسيط الآلي. RecenterControls_01.accdb

Thanks a lot my dear Hassona for sharing

وعليكم السلام ورحمة الله وبركاته للفائدة جرب هذا الملف

واياكم اخى محمد بالتوفيق

السلام عليكم ورحمه الله وبركاته اخى ومعلمى وشيخنا الجليل @ابوخليل بالنسبه لهذا الموضوع وما مررت به بانه فى حاله لم يتم تحويل البرنامج الى accde فان الامور كلها تمام ولكن فى حاله التحويل يلزم التحويل على نفس بيئه العمل لضمان التحويل والعمل بشكل سليم وكما ورد بالموضوع التالى لاخى العزيز @ابو جودي والله اعلى واعلم

In worksheet module, paste the following code Private Sub Worksheet_Change(ByVal Target As Range) Dim x, m As Long If Target.Address = "$E$2" Then If Target.Value = Empty Then Exit Sub x = Application.Match(Val(Target.Value), Columns(1), 0) If Not IsError(x) Then With Sheets("Copied") m = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Rows(x).Copy .Cells(m, 1) End With MsgBox "Row " & x & " Copied Successfully", 64 Else MsgBox "No Found", vbExclamation: Exit Sub End If End If End Sub

برنامج للقرآن الكريم بالأكسس https://drive.google.com/file/d/1oo09ouXvc-3hKYEz3d71avbjckzFfvAG/view

وعليكم السلام ورحمه الله وبركاته اتفضل اخى واستاذى محمد @أبو عبدالله الحلوانى Dim QryStr As String 'On Error Resume Next QryStr = "INSERT INTO InvoiceDetailTbl ( IDs, OldInvs, jyarID, Movtyp, StorID, DmanSt, VoicDtID, Quentity, price ) " & _ "SELECT MovmentTbl.ID, MovmentTbl.OldInvs, MovmentTbl.jyarID, 2 AS MovTyp, MovmentTbl.StorID, MovmentTbl.AoryntID, " & _ "'" & InvNo & "' AS InvExp, MovmentTbl.QntyOut, MovmentTbl.AmtJyarOut FROM MovmentTbl " & _ "WHERE (((MovmentTbl.BlajID)='" & bljNo & "'));" بالتوفيق

الجدول EnEx1 لو لاحظت فيه مفتاحين وعادة هذه المفاتيح ترفض التكرار .... لذلك عند الالحاق يرفض لتكرار هذين الحقلين طبعا ولا يتم الالحاق فقط حذفنا المفتاحين وحولناها حقول عادية ليقبل التكرار ...

تفضل الملف بعد التعديل <><><><><><><><<><><> ‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏HR19-2-2023.rar

طيب يا استاذي الكريم :::: من اساس الفكرة هي استعلام الحاق :::: تم الحاق اصحاب الفترة المسائية ثم الحاق اصحاب الفترة الصباحية وهذا ما مان في المرفق السابق احتجنا استعلام ثالث وهو الحاق اصحاب الفترة الثانية ( الدوام الثاني ) فاضفت لك هذا الاستعلام الثالث انظر الكود وقارن بالكود السابق .... DoCmd.SetWarnings False CurrentDb.Execute ("Delete * From EnEx1") 'استعلام الحاق اصحاب الفترة المسائية DoCmd.RunSQL "INSERT INTO EnEx1 ( ID, Ddate, ExDate, EnDate ) SELECT EnEx.ID, EnEx.Ddate, [Ddate] & "" "" & [ExDate] AS ex, [Ddate] & "" "" & [enDate] AS en FROM EnEx WHERE (((EnEx.EnDate)<>#12/30/1899 23:0:0#) AND ((EnEx.ExDate)<>#12/30/1899 23:0:0#));" 'استعلام الحاق اصحاب الفترة الصباحية DoCmd.RunSQL "INSERT INTO EnEx1 ( ID, Ddate, ExDate, EnDate ) SELECT EnEx.ID, EnEx.Ddate, [Ddate]+1 & "" "" & [ExDate] AS ex, [Ddate] & "" "" & [enDate] AS en FROM EnEx WHERE (((EnEx.EnDate)=#12/30/1899 23:0:0#));" 'استعلام الحاق اصحاب الفترة( الدوام الثاني ) DoCmd.RunSQL "INSERT INTO EnEx1 ( ID, Ddate, ExDate, EnDate ) SELECT EnEx.ID, EnEx.Ddate, [Ddate] & "" "" & [ExDate2] AS ex, [Ddate] & "" "" & [enDate2] AS en FROM EnEx WHERE (((EnEx.EnDate2) Is Not Null));" DoCmd.SetWarnings True DoCmd.OpenQuery "Tat_kan", acViewNormal ملاحظة:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: لن يعمل معك بالشكل الصحيح عند التطبيق الان ( حاول تعرف السبب ) .... ههههههه تحتاج تغيير جدول EnEx1 حاول .... وسوف ادرج لك الملف بعد ربع ساعة من الان .... لكسب الوقت ....

اخي الكريم ابحث في المنتدى تجد العديد من هذه الافكار مثل هذه

وعليكم السلام ورحمة الله وبركاته الحقيقة لم افهم الية عمل الصلاحيات لديك .... لكن جرب هذا ربما هو ما تريد .... مثال (3).accdb

فكر وحاول تعملها لوحدك .... واذا لم تستطع ساعدناك ...... ( علمني كيف اصطاد ) ........ انظر ......

طيب التعديلات في اضافة نموذج1 و استعلام Tat_kan و موديول Module1 افتح النموذج 1 ثم اضغط على عملية الاحتساب جرب واعلمنا بالنتيجة ..... ‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏‏HR19-2-2023.rar

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

كلامك صحيح مئة بالمئة عارف المشكلة اين أخي @ابوخليل كيف يمكن من خلال جدولة التمييز بين الفترات !!!! فلذلك التصميم الصحيح للجداول مهم جدااااااااااااا اخي @ابو مهند شتية هل هنا جدول لتوزيع دوام الموظفين ..... بمعنى انا موظف لديك .... كيف اعرف ايام وفترات دوامي ؟؟؟؟ هل هنا جدول اسبوعي مثلا لتغيير هذه الفترات او شهري اوووووو .... كيف يمكن معرفة ان دوام kanory غدا 7 صباحا مثلا وليس 9 صباحا

اخي @ابو مهند شتية ممكن تزيد من عدد البيانات الموجودة في الجدول حتى نستطيع مساعدتك في هذه المشكلة ..... لاني ارى هذا الموظف بياناته مختلفة عن سابقة ... انظر .... لا حظ الموظفين ( 1001 - 1005 ) لديهم خروج دوام اول اما الموظف ( 1009 ) ليس لديه خروج دوام اول هل هناك حالات لموظفي اخرين بنفس الطريقة أم هي غلطة مطبيعة .... لانها جزء من الحل الذي افكر فيه ... ارجو التوضيح .... بارك الله فيك

حياك الله اخي @حسين العربى

السلام عليكم عندي نموذج به عدة حقول ، وأريد وضع زر ينسخ قيمة أحد القول في ذاكرة الجهاز لأستعمله في برنامج آخر ( بدلا من استخدام ctrl c ) شاكر ومقدر لهذا المنبع الثّر بعطاءه تحياتي الشاعر

Press Alt + F11 > Insert Module > Paste the UDF I am sure you didn't do these steps. This is user-defined function which is not implemented in excel functions