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

السلام عليكم و رحمة الله ضع الكود الاول فى موديول عادى Sub HidColmns() Dim ws As Worksheet, SRng As String Dim FrRng As Range, SeRng As Range, ThRng As Range Dim LR As Long Set ws = Sheets("ورقة1") LR = ws.Range("B" & Rows.Count).End(3).Row SRng = ws.Range("C2").Text Set FrRng = ws.Range("F5:H" & LR) Set SeRng = ws.Range("I5:K" & LR) Set ThRng = ws.Range("L5:N" & LR) Application.ScreenUpdating = False Select Case SRng Case "الأول" FrRng.Columns.Hidden = False SeRng.Columns.Hidden = True: ThRng.Columns.Hidden = True Case "الثاني" SeRng.Columns.Hidden = False FrRng.Columns.Hidden = True: ThRng.Columns.Hidden = True Case "المجاميع" ThRng.Columns.Hidden = False FrRng.Columns.Hidden = True: SeRng.Columns.Hidden = True Case Else End Select Application.ScreenUpdating = True End Sub اما الكود الثانى فضعه فى حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$C$2" Then Exit Sub HidColmns End Sub

In standard module put the following code #If Win64 Then Private Declare PtrSafe Function GetKeyboardLayout Lib "user32" (ByVal idThread As Long) As Long Private Declare PtrSafe Function Keyboard Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal ss As String, ByVal sss As Long) As LongPtr #Else Private Declare Function GetKeyboardLayout Lib "user32" (ByVal idThread As Long) As Long Private Declare Function Keyboard Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal ss As String, ByVal sss As Long) As Long #End If Public Function GetCurrentKeyboardLayout() As String GetCurrentKeyboardLayout = Hex(GetKeyboardLayout(0)) End Function Public Sub SetEnglish() Call Keyboard("00000409", 1) End Sub Public Sub SetArabic() Call Keyboard("00000401", 1) End Sub Then in worksheet module put the following code Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 2 Then If GetCurrentKeyboardLayout = "00000409" Then Exit Sub Call SetEnglish Else If GetCurrentKeyboardLayout = "00000401" Then Exit Sub Call SetArabic End If End Sub

Peace be upon you. Try the following UDF in standard module Function ElapsedPercent(ByVal startDate, ByVal endDate, ByVal checkDate) If IsEmpty(startDate) Or IsEmpty(endDate) Or IsEmpty(checkDate) Or Not IsDate(startDate) Or Not IsDate(endDate) Or Not IsDate(checkDate) Then ElapsedPercent = vbNullString: Exit Function End If If checkDate < startDate Then ElapsedPercent = "Not Yet" ElseIf checkDate > endDate Then ElapsedPercent = "100%" Else ElapsedPercent = Format((checkDate - startDate + 1) / (endDate - startDate + 1), "0%") End If End Function Then you can use the UDF as following =ElapsedPercent(D12,E12,B12) Another solution using Formula =IF(OR(ISBLANK(D12), ISBLANK(E12), ISBLANK(B12)), "",IF(B12 < D12, "Not Yet",IF(B12 > E12, "100%",TEXT((B12 - D12 + 1) / (E12 - D12 + 1), "0%"))))

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

يمكن الاطلاع على هذا الموضوع يمكن يفيدك مع ملاحظة أنه سوف يتم عمل كود يوضع في حدث فتح الملف كي يعمل تلقائي https://www.officena.net/ib/topic/58863-ارسال-رساله-الي-الايميل-بانتهاء-المده/

وعليكم السلام 🙂 مواضيع مماثلة ومحلولة :

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

وعليكم السلام ورحمة الله وبركات يمكن الاطلاع على الروابط التالية يمكن تفيدك

وعليكم السلام ورحمة الله وبركاتة تفضل تثبيت الصفوف.xlsm

ابشروا بالخيـر ان شاء الله

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

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

أخي النجاشي 🙂 حسب فهمي للموضوع .. موضوعك مختلف عن موضوع تسجيل الغياب نوعا ما كفكرة .. ولكن يخدمك أنت تصميم النموذج الحالي .. يمكنك الاستفادة من التصميم الحالي والبدء بعمل نموذج جديد مخصص لموضوع الميراث .. وقبل أن تبدأ بالعمل في الأكسس .. أقترح عليك أن ترسم النموذج على ورقة حتى تتضح لديك الرؤية وتعلم جميع احتياجاتك .. بعدها إبدأ ببناء الجداول بشكل صحيح مع علاقاتها .. ( جدول للورثة - وجدول للممتلكات - وجدول لحساب وتوزيع أنصبة الورثة ) ثم أنشيء النماذج ... (نموذجي إدخال لكل من (جدول للورثة - وجدول للممتلكات) ، ونموذج لحساب الميراث شبيه بالنموذج الحالي مصدره جدول الممتلكات وبه نموذج فرعي لحساب نصيب كل وارث ) هذا ما يتبادر لذهني حاليا .. 🙂 وأعتذر لك عن بناء قاعدة البيانات لضيق الوقت 🌹

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

الحمدلله على سلامتك حبيبنا @ابو جودي 🙂 🌹 عودا حميدا .. ومطول الغيبات جايب الغنايم 😄 ورجعت معاك الحياة للمكتبة الغانمة ☺️👌🏼

جعله الله في ميزان حسناتك استاذ

السلام عليكم اخي @كريم نظيم للاسف ما زبط معي اشكرك لاهتمامك 🙂

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

ضع المؤشر على اخر خلية في المجموع واختر فرز من الاصغر الى الاكبر

Peace be upon you More details will be more useful indeed Mention the form you are working on [UserForm1] and the worksheet you would like to search in and the column you are dealing will and give some examples of results

مرحبا بك في أي وقت الاكواد كما يلي طباعة الصفحة الحالية ( صفحة واحدة ) Sub print_1() ActiveWindow.SelectedSheets.PrintOut From:=1, to:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False End Sub طباعة كل الموظفين ( ولعمل ذلك تم عمل عمود مساعد لوضع رقم مسلسل للموظفين ) Sub print_1() ActiveWindow.SelectedSheets.PrintOut From:=1, to:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False End Sub Sub print_all() ' الاعلان عن متغير من النوع الرقمي الصحيح Dim x As Integer 'عمل حلقة تكرارية بديتها القيمة الموجودفي في الخلية ام 3 وتنتهي في الخلية ام 4 For x = [m3] To [m4] 'أمر الطباعة ActiveWindow.SelectedSheets.PrintOut From:=1, to:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False ' زيادة القيمة في الخلية بمقدار 1 للانتقال للشخص التالي [m3] = [m3] + 1 ' تكرار التنفيذ Next [m3] = 1 End Sub إذا كنت لا ترغب في العمود المساعد يمكنك عمل الرقم الوظيفي قائمة منسدلة ويمكنك الاطلاع على الرابط التالي الكود في الأساس للاستاذ بن عليه حاجي على ما أتذكر ( فقط تم توظيفه ليناسب طلب السائل ) الاداة التي تنقل بين أرقام الموظفين ( أداة تحكم ) لا يوجد بها كود فقط يمكن ضبطها من خلال خصائصها طباعة الكل ومفرد.xlsm

اتفضل استخدم الكود الاتى فى وحدة نمطية Public Function OfficenaGeneratePwd(Optional iNoChars As Integer = 10, _ Optional bNumeric As Boolean = True, _ Optional bUpperAlpha As Boolean = True, _ Optional bLowerAlpha As Boolean = True, _ Optional bSpecialChr As Boolean = True, _ Optional sSpecialChr As String = "'?,./<>|\[]{}:;#$%&()*+-@_""" & "!`~@#$%^&*()=€¥»«©®™°¢£•÷׶") On Error GoTo Error_Handler Dim AllowedChars() As Variant Dim iCounter As Integer Dim i As Integer Dim iRndChar As Integer Dim iNoAllowedChars As Long Const sModName = "modGeneratorPassword" 'Initialize our array otherwise it throws an error ReDim Preserve AllowedChars(0) AllowedChars(0) = "" 'Numeric If bNumeric = True Then For i = 48 To 57 iCounter = UBound(AllowedChars) ReDim Preserve AllowedChars(iCounter + 1) AllowedChars(iCounter + 1) = i Next i End If 'Uppercase Alphabet If bUpperAlpha = True Then For i = 65 To 90 ReDim Preserve AllowedChars(UBound(AllowedChars) + 1) iCounter = UBound(AllowedChars) AllowedChars(iCounter) = i Next i End If 'Lowercase Alphabet If bLowerAlpha = True Then For i = 97 To 122 ReDim Preserve AllowedChars(UBound(AllowedChars) + 1) iCounter = UBound(AllowedChars) AllowedChars(iCounter) = i Next i End If 'Special Characters If bSpecialChr = True Then If Trim(sSpecialChr) <> "" Then For i = 1 To Len(sSpecialChr) ReDim Preserve AllowedChars(UBound(AllowedChars) + 1) iCounter = UBound(AllowedChars) AllowedChars(iCounter) = Asc(Mid$(sSpecialChr, i, 1)) Next i End If End If 'Generate Password iNoAllowedChars = UBound(AllowedChars) For i = 1 To iNoChars iRndChar = Int((iNoAllowedChars * Rnd) + 1) OfficenaGeneratePwd = OfficenaGeneratePwd & Replace(Chr(AllowedChars(iRndChar)), "'", "''") Next i Error_Handler_Exit: On Error Resume Next Exit Function Error_Handler: MsgBox "The following error has occured." & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: " & sModName & "/OfficenaGeneratePwd" & vbCrLf & _ "Error Description: " & Err.Description, _ vbCritical, "An Error has Occured!" Resume Error_Handler_Exit End Function يتم استدعاء الكود كالاتى OfficenaGeneratePwd(10, true, true,True,True) الرقم 10 طول السلسلة النصية المكونة للباسورد >>---> طبعا يمكن تغيره حسب حاجتكم الـ True الاولى لاستخدام الأرقام لو لا تريد استخدام الأرقام اجعلها False الـ True الثانية لاستخدام الحروف الكابيتال لو لا تريد استخدام الحروف الكابيتال اجعلها False الـ True الثالثة لاستخدام الحروف الاسمول لو لا تريد استخدام الحروف الاسمول اجعلها False الـ True الرابعة لاستخدام الرموز الخاصة لو لا تريد استخدام الرموز الخاصة اجعلها False انا وضعت بالكود الرموز الخاصة جاهزة والتى تناسبنى ولكن انا لا اجبر المستخدم على استخدام الكود كما هو جعلت مرونة فى الكود بحيث يمكن للمستخدم وضع الرموز فقط التى يفضلها على سبيل المثال نريد استخدام الرموز الاتية فقط -+*/ يكون استدعاء الكود بالشكل الاتى OfficenaGeneratePwd(10, true, true, True, True, "-+*/")

تفضل أخي تم عمل طلبك الاول اما الثاني تم اضافة جدول (tbl_Data) للترحيل به ........... ووافني بالرد electrivahro-1.accdb

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

ممتاز يابو أحمد .. 🙂 مقترح : ممكن تطبيقها في تقويم جدولي .. بحيث تتلون الفترة اللي يتم اختيارها بلون مختلف 🙂 .

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

Remove all the code in ThisWorbook module before executing the following code. Also make the worksheet you desire to copy to be Active Sub Test() Dim ws As Worksheet, sh As Worksheet, sName As String, cnt As Long Set ws = ActiveSheet cnt = 1 If InStr(ws.Name, "-") Then sName = Left(ws.Name, 3) & Right(Year(Date), 2) Else MsgBox "Worksheet Name Should Have A Hyphen", vbExclamation: Exit Sub End If Do While SheetExists(sName & "-" & cnt) = True cnt = cnt + 1 Loop If cnt > 12 Then MsgBox "The Number of Copies Has Reached Its Limit.", vbExclamation: Exit Sub End If ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Set sh = ActiveSheet sh.Name = sName & "-" & cnt End Sub Function SheetExists(ByVal sheetName As String) As Boolean Dim ws As Worksheet On Error Resume Next Set ws = ThisWorkbook.Sheets(sheetName) On Error GoTo 0 If ws Is Nothing Then SheetExists = False Else SheetExists = True End Function

شوف هذا الموضوع اعتقد بيفيدك تبني فكرة القاعدة عليه

تعديل على التعديل السابق 🙂 التعديل السابق لتقريب الكسور إلى أقرب رقم صحيح كان يحول الخلايا الفاضية إلى أصفار وهذا خطأ لأن البرنامج يفرق بين الصفر والتي هي درجة تحصيل والخانة الفاضية والتي كان يعتبرها البرنامج غياب. التعديل في هذا السطر: من If IsNumeric(.Value) Then إلى If .Value <> "" And IsNumeric(.Value) Then توزيع القرار لمدارس العراق_06.xlsm

جرب هيك اخي الكريم شوف اذا كان هيك طلبك صيانة.mdb

السلام عليكم 🙂 هذا المنتدى للتبادل العلمي ، حتى يستفيد منه الجميع ، وليس صاحب الموضوع / السؤال فقط 🙂 فيا ريت ان نضع الاجابة بالتفصيل في الرد (سواء الخطوات او الكود او صور من شاشة البرنامج) ، ولا نتوقف عند ارفاق المرفق الذي به الرد / الجواب ، والسبب هو ، حتى يستطيع الجميع رؤية الرد ومعرفته مباشرة ، دون اللجوء الى انزال المرفق وفهمه 🙂 نعم ، هذا عبء إضافي ، ولكن نتائجه ستكون مثمرة ان شاء الله 🙂 وتذكروا ، هذا مجرد طلب ورجاء ، وليس اجباري 🙂 شكرا جزيلا 🙂 جعفر