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

تفظل جريب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim cell As Range Set ws = ThisWorkbook.Sheets("Sheet1") If Not Intersect(Target, ws.Columns("A")) Is Nothing Then Application.EnableEvents = False For Each cell In Target If cell.Value <> "" Then Dim charCount As Long charCount = Len(cell.Value) - Len(Replace(cell.Value, " ", "")) Dim fontSize As Long fontSize = 14 - charCount If fontSize < 8 Then fontSize = 8 End If cell.Font.Size = fontSize End If Next cell Application.EnableEvents = True End If End Sub

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

تم الانتهاء من الفحص ومرفق الملف الأخير. ايام عمل_07.xlsm

ترددت كثيرا في المشاركة في موضوع هذا العضو والمصلحة العامة تحتم ذكر السبب لأنه ويوجد بعض الأعضاء مثله لا يراعون سياسة المنتدى كفتح موضوع جديد عند تأخر الإجابة في موضوع سابق وأيضا إهمال المواضيع بعد الحصول على الحل مشرفي المنتدى لم يضعوا تحديد أفضل إجابة أو زر إعجاب مكافأة لمن قدم الحل وإنما لتأسيس بنك معلوماتي ومرجع لمن أراد البحث والاستفادة مستقبلا وعدم وجود أفضل إجابة أو إعجابات على الإجابات الصحيحة في المواضيع ستجعل من يبحث يتخطى هذا الموضوع وفائدة أخرى عندما تتفاعل مع من يقدم لك الحل تنمو العلاقة والتواصل الإيجابي بينك وبين الأعضاء فالدعاء وكلمة الشكر والاعجاب هم السبيل الوحيد لذلك ومن خلالها أيضا تقدم خدمة لنفسك فيتسابق الجميع لمشاركتك ومساعدتك سأضع الأكواد هنا للفائدة لأن الملف أشبه بتطبيق EXE متعب في الوصول للأكواد Private Sub CommandButton1_Click() Dim LRow As Long Dim namsh As String Dim wk, wk2 As Worksheet Dim x As Integer Dim check As Boolean namsh = "temp" Set wk = Worksheets("التكويد") 'التأكد من عدم وجود الورقة المؤقته وإضافتها For Each wk2 In Worksheets If wk2.Name Like namsh Then check = True: Exit For Next If check = False Then With ThisWorkbook .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = namsh End With End If 'ترحيل الصفوف المختارة Set wk2 = Worksheets(namsh) wk2.Range("A1:E9999") = "" LRow = wk.Range("A999").End(xlUp).Row wk.Range("A1:A" & LRow & ",E1:E" & LRow & ",R1:R" & LRow & ",S1:S" & LRow & ",T1:T" & LRow).Copy wk2.Range("A1") With wk2 'إضافة المجاميع في الصف الأخير Rowz = Application.WorksheetFunction.Subtotal(2, .Range("A2:A" & Rows(Rows.Count).End(xlUp).Row)) .Range("B" & Rowz + 2) = "الاجمالي" .Range("C" & Rowz + 2) = "=ROUND(SUM(C2:C" & Rowz + 1 & "),2)" .Range("D" & Rowz + 2) = "=ROUND(SUM(D2:D" & Rowz + 1 & "),2)" .Range("E" & Rowz + 2) = "=ROUND(SUM(E2:E" & Rowz + 1 & "),2)" .Columns("A:E").AutoFit 'تنسيق الصف الأخير الخاص بالمجموع ' With wk2.Range("B" & Rowz + 2 & ":E" & Rowz + 2) .AddIndent = True .Font.FontStyle = "Times New Roman" .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Interior.Color = RGB(237, 237, 220) .Font.Bold = False .Font.Bold = True End With .PageSetup.PrintArea = "A1:E" & Rowz + 2 'LRow Application.Dialogs(xlDialogPrint).Show End With ' Application.DisplayAlerts = False 'التأكد من وجود الورقة المؤقته وحذفها If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub If Evaluate("=ISREF('" & namsh & "'!A1)") Then Sheets(namsh).Delete End If Application.DisplayAlerts = True End Sub 'عمل فلتر على محتوى الكمبوبوكس Private Sub CommandButton2_Click() With Worksheets("التكويد").Range("A1:T1") 'إلغاء الفلتر If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If If Me.ComboBox1.Text = "" Then Exit Sub .AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text '& "*" End With 'استدعاء الطباعة Call CommandButton1_Click 'إلغاء الفلتر If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If End Sub 'ملء الكمبوبوكس بأسماء السلع بعد حذف التكرار Private Sub UserForm_Activate() If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If Dim wk As Worksheet Set wk = Worksheets("التكويد") Dim v, e LRow = wk.Range("A999").End(xlUp).Row v = wk.Range("C2:C" & LRow).Value With CreateObject("scripting.dictionary") .comparemode = 1 For Each e In v If Not .exists(e) Then .Add e, Nothing Next If .Count Then Me.ComboBox1.List = Application.Transpose(.keys) End With End Sub 81.xlsm

أعتذر المعالجة سليمة واتضحت بعد التعديل على دالتي، والتعديل كان بحذف أيام العطلة الأسبوعية في نهاية المدة. فاستخدام الدالة بهذه الصورة: = WORKDAY(C5,100) - 1 سليما. الدالة بعد التعديل: Function myWorkDay(FmDate As Date, NetDays1 As Integer) As Date 'WORKDAY شبيهة بدالة الاكسل 'FmDate أول يوم عمل Dim Weekends As Integer Dim ToDate As Date Dim NetDays2 As Integer Dim LoopRepeat As Integer Weekends = Int(NetDays1 / 2.5) ToDate = FmDate + NetDays1 + Weekends - 1 Weekends = CountWkDay(FmDate, ToDate, vbFriday) + _ CountWkDay(FmDate, ToDate, vbSaturday) NetDays2 = ToDate - FmDate - Weekends + 1 Do While NetDays1 <> NetDays2 LoopRepeat = LoopRepeat + 1 If LoopRepeat = 10 Then 'Debug.Print "LoopRepeat", LoopRepeat Exit Do End If If NetDays1 > NetDays2 Then NetDays2 = NetDays2 + 1 Else NetDays2 = NetDays2 - 1 End If ToDate = FmDate + NetDays2 + Weekends - 1 Weekends = CountWkDay(FmDate, ToDate, vbFriday) + _ CountWkDay(FmDate, ToDate, vbSaturday) NetDays2 = ToDate - FmDate - Weekends + 1 Loop If Weekday(ToDate) >= vbFriday Then ToDate = ToDate - 1 If Weekday(ToDate) >= vbFriday Then ToDate = ToDate - 1 myWorkDay = ToDate End Function وعليه لا حاجة لمستخدمي الاكسل لدالتي، وتبقى مطلوبة لمستخدمي الأكسس. يبقى فحص دالة واحدة فقط.

اخي بسام كل طلب اجعله في موضوع وعنوان جديد وفقك الله

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

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

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

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

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

بارك الله فيك اشكرك على جهودك ، ربنا يديم عليك الصحة والعافية ويرزقك الجنة في الاخرة ❤️

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

لازال الأمر يثير اهتمامي و هذه محاولة أخيييييرة تم فيها الاستغناء عن العمود T يوجد نوعان من الرسائل اضغط L7 , L8 ولاحظ الفرق ملاحظة : الأعمدة من T إلى DK يستخدمهم البرنامج لإعداد رسائل الواتساب أرجو أن تنجح التجربة Send Via Whatsapp (4).xlsm

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

Private Declare PtrSafe Function ActivateKeyboardLayout Lib "user32.dll" (ByVal mylanguage As Long, flag As Boolean) As Long Private Const ar = 1025 Private Const Eng = 1033 Private Sub changeToAr(Cancel As Integer) Call ActivateKeyboardLayout(ar, True) End Sub Private Sub changeToEn(Cancel As Integer) Call ActivateKeyboardLayout(Eng, True) End Sub

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

حل اخر استخدم هذه المعادلة =COUNTIF(D2:D19;"*") حيث D2:D19 هو مدى البيانات و "*" المقصود بها تجاهل القيم الفارغة والمعادلات

السلام عليكم بعد اذن استاذنا الكبير محمد صالح حل اخر يمكن استخدام هذه المعادلة NETWORKDAYS.INTL(C4;C4+D4;7) حيث c4 هى تاريخ البداية و D4 عدد ايام العمل ورقم 7 المقصود به العطلة الاسبوعيه الجمعة والسبت ويمكن تغييره حسب العطله الاسبوعبه ايام عمل.xlsx

يمكنك استعمال هذه المعادلة للتوصل لتاريخ النهاية بعد 100 يوم عمل =WORKDAY.INTL($C$5-1,100,7) وهذه الدالة للإصدارات الأحدث (2010 وما بعدها) تراعي خيارات عطلة نهاية الاسبوع ورقم 7 يعني الجمعة والسبت ويمكن استخدام هذه الدالة للاصدارات الاقدم (2007 وما قبلها) =WORKDAY($c$5,100)-1 هذه الدالة تحسب عدد الأيام على ان اجازة نهاية الاسبوع هي السبت والاحد لذلك تم انقاص يوم من الناتج لتحسب على ان عطلة نهاية الاسبوع الجمعة والسبت ملحوظة: وتم تعديل الملف المرفق ليحسب عدد أيام العمل بين تاريخين للإصدارات القديمة بدالة networkdays والحديثة networkdays.intl بالتوفيق ايام عمل.xlsx

أبوأحمد سبقني 🙂 كيف استخدم زر الزيادة أو نقصان_02.xlsm

استخدم هذه المعادلة غير النطاق حسب الموجود لديك =SUM(SUMPRODUCT((LEN(A1:A444)>3)*1))

وعليكم السلام ورحمة الله وبركاته تفضل قوم بتحديث البيانات في العمود اول مرة عند تضع الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim cell As Range Set ws = ThisWorkbook.Sheets("Sheet1") ' If Not Intersect(Target, ws.Columns("A")) Is Nothing Then Application.EnableEvents = False ص For Each cell In Target If cell.Value <> "" Then Dim wordCount As Long wordCount = Len(cell.Value) - Len(Replace(cell.Value, " ", "")) + 1 If wordCount = 1 Then cell.Font.Size = 14 ElseIf wordCount = 2 Then cell.Font.Size = 14 ' ElseIf wordCount >= 3 Then cell.Font.Size = 14 End If cell.Font.Bold = True cell.Font.Name = "Arial" End If Next cell Application.EnableEvents = True ' End If End Sub

بارك الله فيك وزادك الله من فضله هدية قيمة أحسنتم

وعليكم السلام تفضل شيت مرتبات.xlsx

البقاء لله وان لله وان اليه راحعون اللهم اسكنه فسيج جناتك واغفر له وارحمه ةالهم اللهم اهله الصبر والسلوان على هذه المصيبة واجعله يا الله من أرباب جنات الفردوس الأعلى واحشره مع الصديقين والمرسلين والشهداء وحسن أولئك رفيقاً

المشكلة أخي ليس من اليوزرفورم المشكلة من مكان جلب البيانات حاول مراجعة المعادلة الموجودة في ورقة الادخال عمود CF . وإعادة ظبط نطاق القوائم المنسدلة. المهم تم استبدال عمود جلب البيانات الى عمود CK اي اظافة جديدة أو تعديل قم باظافتها هناك لتظهر معك على الكومبوبوكس مخزون V5.xlsm

وعليكم السلام -يمكنك استخدام هذه المعادلة =IFERROR(INDEX(ورقة1!B2:B270,MATCH(0,COUNTIF($A$1:A1,ورقة1!B2:B270),0)),"") تلخيص1.xlsx

تفضل Test 2.rar

بارك الله فيك -تحت أمرك

تفضل اخى الكريم محمد لك ما طلبت فقد تم العمل كما ترى بالصورة test.rar

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

اخى الكريم شوف بنفسك بارك الله فيك

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

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

وعليكم السلام تفضل-يمكنك تجربة هذه الأكواد طالما انك لم ترفع ملف Private Sub UserForm_Initialize() TextBox1.Text = "" End Sub Private Sub CommandButton1_Click() TextBox1.Text = "Sid" MsgBox "Re-Initialzing the Userform" UserForm_Initialize End Sub Private Sub UserForm_Initialize() ChartNum = 1 UpdateChart_OverallOEE UpdateChart_OverallUnits UpdateChart_OverallWeights End Sub Private Sub UpdateChart_OverallOEE() Set CurrentChart = Sheets("Chart_OverallOEE").ChartObjects(ChartNum).Chart CurrentChart.Parent.Width = 710 CurrentChart.Parent.Height = 150 ' Save chart as GIF Fname = ThisWorkbook.Path & Application.PathSeparator & "Chart_OverallOEE.gif" CurrentChart.Export Filename:=Fname, FilterName:="GIF" ' Show the chart img_Chart_OverallOEE.Picture = LoadPicture(Fname) End Sub Private Sub UpdateChart_OverallUnits() Set CurrentChart = Sheets("Chart_OverallUnits").ChartObjects(ChartNum).Chart CurrentChart.Parent.Width = 700 CurrentChart.Parent.Height = 150 ' Save chart as GIF Fname = ThisWorkbook.Path & Application.PathSeparator & "Chart_OverallUnits.gif" CurrentChart.Export Filename:=Fname, FilterName:="GIF" ' Show the chart img_Chart_OverallUnits.Picture = LoadPicture(Fname) End Sub Private Sub UpdateChart_OverallWeights() Set CurrentChart = Sheets("Chart_OverallWeights").ChartObjects(ChartNum).Chart CurrentChart.Parent.Width = 700 CurrentChart.Parent.Height = 175 ' Save chart as GIF Fname = ThisWorkbook.Path & Application.PathSeparator & "Chart_OverallWeights.gif" CurrentChart.Export Filename:=Fname, FilterName:="GIF" ' Show the chart img_Chart_OverallWeights.Picture = LoadPicture(Fname) End Sub

وعليكم السلام كان عليك من البداية استخدام خاصية البحث فى المنتدى تفضل https://www.officena.net/ib/topic/87818-استفسار-عن-طريقة-اضافة-اكثر-من-مستخدم/?tab=comments#comment-555050

تفضل دالة تاريخ.xlsx

احسنت استاذ أحمد بارك الله فيك وجعله فى ميزان حسناتك بعد اذن الأستاذ أحمد بالتأكيد تفضل نموذج.xlsm

وعليكم السلام-لاحظ الصور هذه اسهل طريقة