عبدالله بشير عبدالله

وعليكم السلام ورحمة الله وبركاته الملف المرفق مقال لجداول 3 كلمة السر للاول111 والثاني 222 والثالت 333 يمكن تعديلها من الكود ويمكنك قفل محرر الاكواد بكلمة سر فكرة الكود عند الدخول على الصفخة يتم حماية الجدوال كلها بكلمة سر هي master يمكن تعديلها من الكود للجداول 3 يختار الشخص جدوله يطالب بكلمة سر يكتبها فيتعامل مع جدولة وباقي الجداول محمية يمكنك تعديل نطاف الجداول في الكود اتمنى ان تجد في الملف طلبك تحياتي حماية جدوال متعددة كل جدول بكلمة سر.xlsb

وعليكم السلام ورخمة الله وبركاته اخي لا داعي للاعتذار وملقك ليس مبهما وطلبك يتكرر كثيرا في المنتدى الغموض كان في النتائج المرفقة مع ملفك وخضوصا للسائق اخمد فهي غير صحيحة الملفان السابقان فيهما طلبك ولكن بزر وليس تلقائي فكرة عمل الملف المرفق قم بادخال البيانات لكل السائفين مع العهد والمصروفات ثم استحدم زر الترحيل فيتم انشاء صفخات للسائقين بعدها عند أي تغيير في صفحتي العهدة أو المصروفات، يتم تحديث جميع صفحات السائقين الموجودة تلفائيا ولا تختاج الى زر الترحيل حاليا لديك 3 ملفات كلها تعمل اختر ما يناسب طلبك وكلها تؤدى الى نفس النتيجة اتمنى لك التوفيق جميع السائقين في نفس تلقائي الملف (1).xlsb

السلام عليكم ورحمة الله وبركاته تحياتي لاستاذنا ومعلمنا الفاضل أبوعيد تحياتي للاستاذ الفاضل MAHMOUD ELWY من خلال الاطلاع على الملفات التى ارفقتها لتوضيح الطلب وخصوصا ملف السائق احمد اعتفد ان هناك خطا في فيمة العهدة والمصروفات فهي مكررة وهذا ما اشار اليه استاذنا ابو عيد بعدم لتجاوب السريع من الأعضاء على مشاركتك لوجود الغموض فحسب الصورة العهدة 20000 ولبس 40000 والمصروف 5500 بدل 11000 ويتبقى مع السائق 14500 وليس 29000 هذا خسب قهمى وان كنت مخطئا فارجو توضيخ كيف اتت هذه الارقام وبتاء على فهمى السابق اليك ملفان اخدهما يتشئ ملقات جديدة لكل سائق والاخر في نفس الملف واعتقد لا يوثر ولا يسبب ثقلا للملف كل سائق ملف جديد.xlsbجميع السائقين في نفس الملف.xlsb

وعليكم السلام ورحمة الله وبركانه اليك التصحيج Sub Filter_Class2() Dim WSdest As Worksheet: Set WSdest = Sheets("TI3DAD") Dim D1 As Object, D2 As Object, D3 As Object, D4 As Object Dim I As Long, x As Long, Y As Long, m As Long, z As Long Dim Réf As Variant, ky As Variant, Rng As String Set D1 = CreateObject("Scripting.Dictionary") Set D2 = CreateObject("Scripting.Dictionary") Set D3 = CreateObject("Scripting.Dictionary") Set D4 = CreateObject("Scripting.Dictionary") x = 0: Y = 0: m = 0: z = 0 With WSdest Application.ScreenUpdating = False .Range("M4:V32,X4:AG32,AI4:AR32,AT4:BC32").ClearContents I = 7 Do While I <= .Rows.Count If .Cells(I, 2) <> "" Then Rng = Left(Trim(.Cells(I, 2).Value), 1) Réf = Application.Transpose(.Cells(I, 2).Resize(, 13).Value) Réf = Application.Transpose(Réf) Select Case Rng Case "4" D4(z) = Join(Réf, "*") z = z + 1 Case "3" D3(Y) = Join(Réf, "*") Y = Y + 1 Case "2" D2(x) = Join(Réf, "*") x = x + 1 Case "1" D1(m) = Join(Réf, "*") m = m + 1 End Select I = I + 1 Else Exit Do End If Loop m = 4 If D4.Count > 0 Then For Each ky In D4.Keys .Cells(m, "M").Resize(, 13).Value = Split(D4(ky), "*") m = m + 1 Next ky End If m = 4 If D3.Count > 0 Then For Each ky In D3.Keys .Cells(m, "X").Resize(, 13).Value = Split(D3(ky), "*") m = m + 1 Next ky End If m = 4 If D2.Count > 0 Then For Each ky In D2.Keys .Cells(m, "AI").Resize(, 13).Value = Split(D2(ky), "*") m = m + 1 Next ky End If m = 4 If D1.Count > 0 Then For Each ky In D1.Keys .Cells(m, "AT").Resize(, 13).Value = Split(D1(ky), "*") m = m + 1 Next ky End If .Range("M4").CurrentRegion.Value = .Range("M4").CurrentRegion.Value .Range("X4").CurrentRegion.Value = .Range("X4").CurrentRegion.Value .Range("AI4").CurrentRegion.Value = .Range("AI4").CurrentRegion.Value .Range("AT4").CurrentRegion.Value = .Range("AT4").CurrentRegion.Value Application.ScreenUpdating = True End With End Sub 1تعداد.xlsm

"ههههه والله صدقت، حتى أنا طعج مخي 😂 الله يبارك فيك أستاذي." سؤال طعج مخي حبة الدواء كيف تعرف مكان الوجع!! الملف الذي طعج مخك ومخي اعتقد ان الصفحات الخاصة بالمدن ليس لها علاقة بطلب صاحب السؤال واعتفد انه يريد ترحيل كل مسؤول الى صفحة مستقلة ننتظر صاحب الطلب الفاضل لزيادة التوضيح

السلام عليكم ورحمة الله وبركاته جزاك الله خيرا اخونا Foksh ارحو تعديل الكود بحيث يتم الترحيل خسب المسؤول وليس المدن بالتوفيق استاذنا

السلام عليكم ورحمة الله وبركاته يمكن الاستغناء عن العمود المساعد واستبدال المعادلات في العمود v باخرى ولكنها ستكون طويلة الملف ارقام النتائج عربي2.xlsm

الشئ البسيط يرجعنا الى نقطة الصفر واظهار 99.6 الى 99.60 يمكن وذلك باضافة 0.00 للنتسيق وستصبخ 99.6 الى 99.60 لكن ستظهر الاصفار الارقام الصحيحة 100.00 يعنى تحل اشكال يظهر اخر واعتقد خسب علمى طلبك الاخير لا يتحقق بالتنسيق للخلايا (حسب ما اعلم) بعمود مساعد في Z نضع المعادلات الاصلية به مع النتسيق السابق وفي العمود V نضع المعادلات الجديدة ويمكنك اخفاء العمود Z جرب واتمنى ان تجد طلبك في الملف المرفق او ان يقدم الزملاء بالمنتدى افكار احرى وابسط تحياتي ارقام النتائج عربي1.xlsm

وعليكم السلام ورخمة الله وبركاته هذا التنسيق فيه طلبك مع وجود نقطة للارقام الصحيحة وحقيقة حاولت معالجتها ولم افلح لان النقطة مرتبطة للارقام التي بها كسور ربما احد الزملاء لديه حل اقضل [$-2010401]0.##"٪";-0.##"٪";; ارقام النتائج عربي.xlsm

نعم استاذى الفاضل Foksh صدفت وشكرا لتنبيهك كما اشكر صاخب السؤال الفاضل soik225998 على تنبيهنا للامر تم معالجة الامر ان شاء الله المرشحين2.xlsb

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

اليك التعديل كلمة المرور 1234 اظافة زر تعديل وخذف للفورم.xlsm

وعليكم السلام ورحمة الله وبركاته قم باظافة الكودين الى الفورم3 Private Sub CommandButton4_Click() Dim sh1 As Worksheet, F As Range Set sh1 = Sheet1 If Me.cl.Value = "" Then MsgBox "يرجى البحث عن إذن أولاً قبل التعديل", vbExclamation Exit Sub End If Set F = sh1.Range("d:d").Find(Me.cl.Value, , xlValues, xlWhole, , , False) If Not F Is Nothing Then sh1.Range("A" & F.Row).Value = Me.cust.Value sh1.Range("b" & F.Row).Value = Me.qu.Value sh1.Range("c" & F.Row).Value = Me.fq.Value sh1.Range("e" & F.Row).Value = Me.mq.Value sh1.Range("f" & F.Row).Value = Me.t1.Value sh1.Range("g" & F.Row).Value = Me.fk.Value sh1.Range("h" & F.Row).Value = Me.fm.Value MsgBox "تم تعديل بيانات الإذن رقم " & Me.cl.Value & " بنجاح", vbInformation Else MsgBox "لم يتم العثور على الإذن رقم " & Me.cl.Value, vbExclamation End If End Sub Private Sub CommandButton5_Click() Dim sh1 As Worksheet, F As Range Set sh1 = Sheet1 If Me.cl.Value = "" Then MsgBox "يرجى البحث عن إذن أولاً قبل الحذف", vbExclamation Exit Sub End If If MsgBox("هل أنت متأكد من حذف الإذن رقم " & Me.cl.Value & "؟", vbYesNo + vbQuestion, "تأكيد الحذف") = vbYes Then Set F = sh1.Range("d:d").Find(Me.cl.Value, , xlValues, xlWhole, , , False) If Not F Is Nothing Then sh1.Rows(F.Row).Delete CommandButton3_Click MsgBox "تم حذف الإذن رقم " & Me.cl.Value & " بنجاح", vbInformation Else MsgBox "لم يتم العثور على الإذن رقم " & Me.cl.Value, vbExclamation End If End If End Sub اظافة زر تعديل وخذف للفورم.xlsm ارجو ان تكون في هذه الاجابة فيها طلبك تحياتي

السلام عليكم ورحمة الله وبركاته اهلا وسهلا بك في منتدى اوفيسنا اطلعتُ على الموضوع أكثر من ثلاث مرات، ثم تركته بسبب غموض الطلب وعدم وجود شرح مفصّل. وفي المرة الرابعة، جلستُ في جلسة فجرية على قهوة العميد (Foksh)، فتمت معرفة طلب أخينا الفاضل بإذن الله. في ورقة CLASS2، وأثناء وضع المعاينة، وجدتُ تقسيمًا للصفوف، حيث تظهر أسماء الصفوف في رأس الصفحة، وفي التذييل التوقيعات. كل صف يحتوي على 50 طالبًا، باستثناء الصف الأخير الذي يضم 51 طالبًا. ويُفترض أن يكون كل 50 طالبًا في ورقة واحدة، موزّعين على عمودين. وإن كان ما فهمته صحيحًا من طلبك، فإليك الملف وفيه محاولة للحل. أما إذا لم يكن هذا هو المطلوب، فإن الشرح الوافي يُسهّل على أعضاء المنتدى الإقبال على المساعدة أكثر. second2026 - Copy.xlsb نخياتي

اعتقد تعنى الفورم1 اظهار العناوين في LISTBOX.xlsm

السلام عليكم اظافة صور المعاملات الطريقة اضغط زر معاملة جديدة ثم املأ البيانات ثم زر اظافة تاتى رسالة باظافة صورة او لا اختر نعم قم باختيار الصورة من الجهاز من اي مكان في جهازك وباي اسم يتم خفظ الصورة. لاظهار صورة المعاملة استخدم البحث يفضل عمل مجلدين للصور للصادر والاخر للوارد لتجميع الصور في مكان محدد والامر اختياري يعود اليك فالكود يتعامل مغ اي صورة قي الجهاز وبأي امتداد االمراسلات الإدارية3.xlsm

وعليكم السلام ورحمة الله وبركاته اعتقد المشكلة ان الاكسل يحاول تفسير التواريخ وفقاً لإعدادات النظام الإقليمية واعتقد ان المشكلة في الشهور من1 الى 9 فقط امالشهور 10-11-12 لا مشكلة الحل هو معاملة القيم كنص بدلاً من تاريخ جرب الكود التالي في زر اظافة مع اعادة تنظيم واختصارالكود جرب واعلمنى بالنتائج وفقك الله Private Sub CommandButton1_Click() Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Dim ws As Worksheet, rng As Range Set ws = Sheet1 If Me.TextBox4 = "" Then: Exit Sub Set rng = ws.Range("a10000").End(xlUp).Offset(1, 0) rng.Offset(0, 0).Value = Me.TextBox1.Value rng.Offset(0, 1).Value = Me.TextBox2.Value rng.Offset(0, 2).Value = Me.TextBox3.Value rng.Offset(0, 3).Value = Me.TextBox4.Value rng.Offset(0, 4).Value = "'" & Me.TextBox5.Text rng.Offset(0, 5).Value = "'" & Me.TextBox6.Text rng.Offset(0, 6).Value = Me.TextBox7.Value rng.Offset(0, 7).Value = Me.TextBox8.Value Dim i As Long For i = 1 To 8 Controls("TextBox" & i).Value = "" Next i Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub

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

السلام عليكم استاذ خيري كيف حالك واتمنى ان تكون بخير وعافيه جرب التعديل التالي للبحث والتعديل والخذف والاظافة البحث بالرقم الأشاري أو البحث بأي جزء من النص المكتوب في الخليةm15 مع احتيار وارد او صادر من القائمة االمراسلات الإدارية1.xlsm تحياتي

السلام عليكم ورحمة الله وبركاته في ملفك تستخدم Shapes TextBox (وهي من النوع Form Control)، فهي لا تدعم حدث Change مباشرة قكرة الاستاذ hegazee بسيطة وعملية ربما تعديل بسيط على الفكرة وهو كتابة الرقم في خلية ويتم ربط الخلية بالتكست الاول في الملف اكتب الرقم في الخلية الصفراء تبادل معلوات ورقتين(2).xlSB عذرا ان لم تستطع طلبك كما تريد ولعل الاعضاء المخترمون لديهم افكار اخرى تخياتي

وعليكم السلام ورحمة الله وبركانه حرب الكود بالملف خلاصة حسب تقرير البصمة1.xlsm

وعليكم السلام ورحمة الله وبركاته اسعدنى ان الملف يعمل لديكم تم اظافة زر جديد لطلبك الاخير وتم ترتيب الاسماء ابجديا مع التجميع الكلي لكل العملاء مع امكانية الطباعة والتحويل الى PDF والمعاينة متابعة (3).xlsm

السلام عليكم بعد اذن استاذنا الفاضل hegazee جرب التعديل التالي تبادل معلوات ورقتين(1).xlsb

وعليكم السلام ورخمة الله وبركاته الملف والاكواد على اكسل 2016 نظام 64 بت ويعمل بكفاءة لدي بدون اي مشاكل وجربته على جهاز احر اكسل 2013 وشغال 100% واكسل 2007 يعمل على نظام 32 بت مايكروسوفت لم تبدأ دعم إصدارات 64-بت من أوفيس إلا ابتداءً من Office 2010. اعتقد السبب ولست جازما بالامر ExportAsFixedFormat (PDF): التصدير هذه الميزة غير مدمجة في Excel 2007 إلا إذا كان مثبتًا "Microsoft Save as PDF or XPS Add-in" هذه الإضافة كانت تُنشر رسميًا من مايكروسوفت ولم تعد متاحة مباشرة على موقع مايكروسوفت بعد انتهاء دعم Office 2007 الغا من موافع اخرى ربما تمون غير موثوقة إذا لم تكن مثبتة ستظهر رسالة خطأ عند التصدير لـ PDF. كما في الصورة لديك نصيحة غير الاصدار 2007 الى اعلى واعتقد ان اصدار 2010 يدعم ميزة التصدير اذا كان مواصفات جهازك عادية اذا كان مواصفات جهازك جيده اصدار من 2016 او 2019 او 2021 جرب الملف على جهاز احر اصداره فوف 2007 هذا خسب علمى وربما للخبراء الافاضل راي اخر اجهله تحياتي

السلام عليكم جرب التعديل التالي التعديل في الجزء wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True الى wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True, AllowFiltering:=True الكود كاملا Sub CopyPrintClear() Dim wsArchive As Worksheet Dim wsPrint As Worksheet Dim lastRow As Long Dim copyRange As Range Dim rowCount As Long Dim i As Long Dim Password As String Dim requiredCells As Variant Dim cell As Variant Dim isIncomplete As Boolean Password = "KHORSHEED.OMAR.2025" ' تعيين الشيتات Set wsPrint = ThisWorkbook.Sheets("طباعة") Set wsArchive = ThisWorkbook.Sheets("أرشيف") ' التحقق من الخلايا المطلوبة requiredCells = Array("A2", "F2", "F3", "C18") isIncomplete = False For Each cell In requiredCells If Trim(wsPrint.Range(cell).Value) = "" Then isIncomplete = True Exit For End If Next cell If isIncomplete Then MsgBox "الملف غير كامل. يرجى تعبئة جميع الخلايا المطلوبة.", vbExclamation Exit Sub End If ' رسالة تأكيد If MsgBox("هل تريد تنفيذ العملية؟", vbYesNo + vbQuestion, "تأكيد") = vbNo Then Exit Sub End If ' رفع الحماية مؤقتًا wsArchive.Unprotect Password:=Password ' تحديد نطاق النسخ Set copyRange = wsPrint.Range("A6:G15") rowCount = copyRange.Rows.Count ' تحديد أول صف فارغ في شيت الأرشيف lastRow = wsArchive.Cells(wsArchive.Rows.Count, "B").End(xlUp).Row + 1 ' نسخ الجدول بالكامل إلى الأرشيف wsArchive.Range("A" & lastRow).Resize(rowCount, 5).Value = copyRange.Value ' نسخ القيم الفردية إلى الأعمدة المطلوبة wsArchive.Range("F" & lastRow & ":F" & lastRow + rowCount - 1).Value = wsPrint.Range("C18").Value wsArchive.Range("J" & lastRow & ":J" & lastRow + rowCount - 1).Value = wsPrint.Range("B3").Value wsArchive.Range("H" & lastRow & ":H" & lastRow + rowCount - 1).Value = wsPrint.Range("F3").Value wsArchive.Range("G" & lastRow & ":G" & lastRow + rowCount - 1).Value = wsPrint.Range("F2").Value wsArchive.Range("I" & lastRow & ":I" & lastRow + rowCount - 1).Value = wsPrint.Range("A2").Value ' تحديد منطقة الطباعة وشطبها wsPrint.PageSetup.PrintArea = "$A$1:$F$18" wsPrint.PrintOut ' مسح البيانات من الشيت wsPrint.Range("A6:A15").ClearContents wsPrint.Range("C6:E15").ClearContents wsPrint.Range("A2").ClearContents wsPrint.Range("F2").ClearContents wsPrint.Range("F3").ClearContents wsPrint.Range("C18").ClearContents ' الطباعة مرة ثانية إذا رغبت wsPrint.PageSetup.PrintArea = "$A$1:$F$18" wsPrint.PrintOut wsArchive.Protect Password:=Password, USERINTERFACEONLY:=True, AllowFiltering:=True ' تنظيف الحافظة Application.CutCopyMode = False ' العودة إلى شيت الطباعة وتحديد الخلية A1 wsPrint.Activate wsPrint.Range("A1").Select End Sub