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

ممكن التعامل مع هذا الملف واختيار 5 ايام متتالية او 7 متفرقة او الكل الاكواد اللازمة Option Explicit Sub test_5Dyas() Rem=====>>> Created By Salim Hasbaya On 30/8/219 Dim str$: str = "غ" Dim cont%, col%, k%: k = 35 Dim i%, x%: i = 3 Dim t%, last_ro% Dim my_text: my_text = "انذار 5 (" Dim X_arr(), m%: m = 1 last_ro = Cells(Rows.Count, 2).End(3).Row Range("Ag5").Resize(last_ro - 4, 7).ClearContents If last_ro < 5 Then Exit Sub For col = 5 To last_ro For x = i To k '========================== If Cells(4, x) = "جمعة" Or Cells(4, x) = "سبت" Then GoTo Next_X End If '========================== If Cells(col, x) = "" Then cont = 0 x = x + 1 End If '========================== cont = cont + IIf(Cells(col, x) <> "", 1, 0) '========================== If cont = 5 Then ReDim Preserve X_arr(1 To m) X_arr(m) = my_text & m & ")" m = m + 1 cont = 0 End If '========================== Next_X: Next x On Error Resume Next t = UBound(X_arr) '========================== If t Then Cells(col, "AG").Resize(1, UBound(X_arr)) = X_arr End If '================================ cont = 0 Erase X_arr: m = 1 Next col End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub test_7Dyas() Rem=====>>> Created By Salim Hasbaya On 29/8/219 Dim str$: str = "غ" Dim cont%, col%, k%: k = 35 Dim i%, x%: i = 3 Dim t%, last_ro% Dim my_text: my_text = "انذار 7 (" Dim X_arr(), m%: m = 1 last_ro = Cells(Rows.Count, 2).End(3).Row Range("Ag5").Resize(last_ro - 4, 3).ClearContents If last_ro < 5 Then Exit Sub For col = 5 To last_ro For x = i To k '========================== If Cells(4, x) = "جمعة" Or Cells(4, x) = "سبت" Then GoTo Next_X End If '========================== '========================== cont = cont + IIf(Cells(col, x) <> "", 1, 0) '========================== If cont = 7 Then ReDim Preserve X_arr(1 To m) X_arr(m) = my_text & m & ")" m = m + 1 cont = 0 End If '========================== Next_X: Next x On Error Resume Next t = UBound(X_arr) '========================== If t Then Cells(col, "Ak").Resize(1, UBound(X_arr)) = X_arr End If '================================ cont = 0 Erase X_arr: m = 1 Next col End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub all_days() Dim ro%, Col_Num%: Col_Num = 30 Dim xx%, My_count% ro = Cells(Rows.Count, "b").End(3).Row Dim kk%, Mon_array() Dim st$: st = "انذار7(" If ro < 5 Then Exit Sub test_5Dyas For xx = 5 To ro My_count = Application.CountIf(Cells(xx, 3).Resize(1, Col_Num), "غ") My_count = My_count \ 7 If My_count = 0 Then GoTo Next_XX For kk = 1 To My_count Cells(xx, "ak").Offset(, kk - 1) = st & kk & ")" Next Next_XX: Next End Sub الملف مرفق Inzar ALL Days.xlsm

السلام عليكم ورحمة الله ربما يفيدك هذا الملف جدول صباحى.xlsm

تم التعديل حسب الفهم... بيارات مستخلص.xlsm

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

طبعا بكود لا يمكن عمل هذا بمعادلة ابدا

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

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

هذا الكود يفي بالغرض ان شاء الله (تم تغيير اسماء الصفحات لنسخ الكود بشكل جيد وعدم الوقوع في مشاكل اللغة حيث تظهر حروف غير معروفة عند البعض) Option Explicit Sub AnyThing() Dim lastrow_1 As Long, counter As Long Dim lastrow_2 As Long, key As Variant Dim sh1 As Worksheet, sh2 As Worksheet Dim rng1, rng2 As Range, p As Variant Dim dict As Object Set sh1 = Sheets("SH1") Set sh2 = Sheets("SH2") sh2.Range("I3").Resize(1000, 3).ClearContents lastrow_1 = sh1.Cells(sh1.Rows.Count, "B").End(3).Row lastrow_2 = sh1.Cells(sh2.Rows.Count, "B").End(3).Row Set rng1 = sh1.Range("A3:D" & lastrow_1) Set rng2 = sh2.Range("A3:D" & lastrow_2) Set dict = CreateObject("Scripting.Dictionary") For Each p In rng1.Columns(2).Cells If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2) Else dict(p.Value & "," & p.Offset(, 1)) = _ dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2) End If Next p '=============================== For Each p In rng2.Columns(2).Cells If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2) Else dict(p.Value & "," & p.Offset(, 1)) = _ dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2) End If Next p '============================== counter = 2 With sh2 For Each key In dict.Keys counter = counter + 1 .Cells(counter, "I").Resize(1, 2) = Split(key, ",") .Cells(counter, "K") = dict(key) Next key End With dict.RemoveAll: Set dict = Nothing Set sh1 = Nothing: Set sh2 = Nothing Set rng1 = Nothing: Set rng2 = Nothing End Sub الملف المرفق Total.xlsm

وعليكم السلام-تفضل لك ما طلبت حساب اجماليات السلع.xls

الله عليك استاذ سليم رائع

جرب المرفق CANCLE PROGRAM2222 (1).xlsm

جرب هذا الكود ... DoCmd.RunCommand acCmdSelectRecord لتحديد السجل

في الخلية M2 انسخ هذه المعادلة واسحب نزولاً =IFERROR(CHOOSE($L2,"ليبي","ليبية"),"") اذا لم تعمل المعادلة معك استبدل الفاصلة " ," بفاصلة منقوطة "; " (حسب اعدادات الجهاز عندك) لتبدو المعادلة بهذا الشكل =IFERROR(CHOOSE($L2;"ليبي";"ليبية");"")

شاهد المرفق حسب طلبك up.rar

بارك الله فيك استاذى الكريم وزادك الله من فضله

بارك الله فيك أستاذنا الفاضل أستاذ / سليم

الله يحفظك أستاذ سليم لو امتلكت ان أعطيك جائزة نوبل لمنحتك اياها لكن طلب اخير أن يظهر الانذار الأول بعد اكتمال 5 ايام متصلة و الانذار الثاني بعد اكتمال 7 ايام متقطعة و العكس

نصيحة مني لك عن تجربة ... أبداء بانشاء الملف وارفقه في موضوعك .. حينها ستجد هنا من يساعدك

يجب عليك الضغط على الإعجاب للأستاذ سليم طالما ان هذا الحل اعجبك واعتقد ان هذا اقل ما تقدمه له لمساعدته في حل مشكلتك

جرب المرفق Info.xlsx

ا/ marwa41 طالما الحل اعجب حضرتك فلابد من إعطاء كل ذي حق حقه والضغط على علامة اعجاب للأستاذ الفاضل بن علية فله الفضل بعد ربنا في حل مشكلتك وأضن ان هذا اقل ما تقوم بفعله تجام من له الفضل في حل هذه المشكلة

تفضل هذه اخي الكريم مجرد فكرة New Microsoft Access قاعدة بيانات.accdb

مشكور اخي سليم دائما مغلبك معاي هذا هو المطلوب

الاخوة الاعزاء تجدون ادناه فكرة مبدئية لعمل معرض صور من روابط صورة خارجية آمل ان يحوز على رضائكم معرض صور فكرة مبدئية.mdb

@MTGFM فكرة جميلة

السلام عليكم ورحمة الله وبركاته تعلمنا فى المرحلة الإبتدائية ان التقريب يتم بالنظر الى العدد 5 الواقع بعد العلامة العشرية ، فمثلا الرقم 125.32458 جنيه يتم تقريبه الى العدد 125.32 جنيه ، بينما يتم عند محررى مرتبات الموظفين تقريبه الى العدد 125.33 جنيه ، على اعتبار ان الرقم 4 هو الاساس فى عملية التقريب وليس الرقم 5 كما هو متعارف عليه فى العمليات الحسابية وهذا الموضوع يضايق محررى المرتبات لعدم وجود دالة فى اكسيل تقوم بهذا التقريب الى ان رزقنى الله سبحانه وتعالى معادلة بسيطة تقوم بعملية هذا التقريب ، وهذه المعادلة هى : =ROUND(B6*15%+0.001;2) وقد توصلت الى هذه المعادلة البسيطة بفضل الله اولا ، ثم بفضل السادة خبراء الموقع الأفاضل الذين تعلمنا ومازلنا نتعلم منهم الكثير من خلال هذا المنتدى الرائع بحق فجزاهم الله جميعا عنا خير الجزاء واليكم ملف العمل : ملف العمل.xls

الف شكر

وعليكم السلام -كان لزاما عليك من البداية رفع ملف وشرح عليه المطلوب بكل دقة تجنبا لعدم اهدار الوقت فخطوات عمل التقييد ومنع ادخال المكرر في عمود كالتالى : نقوم باختيار من قائمة Data data Validation ثم Setting وبعد ذلك Custom وبعد ذلك تقوم بلصق هذه المعادلة في المكان المخصص لذلك في Formula وذلك للتقيد في العمود الأول A Formula =COUNTIF($A$1:A1,A1)=1 وهذا هو ملف العمل تقييد المدخلات.xlsx

تفضل لك كل ما طلبت-نورتنا في المنتدى وضع علامة عشرية بعد رقمين وترحيل بيانات الموظف الى الإستمارة.xlsx

وعليكم السلام-تفضل لك ما طلبت-نورتنا في المنتدى 1فاتورة.xlsm

بارك الله فيك أستاذ وجيه الكود ممتاز ويعمل بكفاءة جعله الله في ميزان حسناتك

سيتم الإضافة تلقائيا الى القائمة المنسدلة بمجرد إدخالها في العمود المخصص لذلك من الصفحة الأخرى

تفضل جرب هذا دليل الهاتف - Copy.xlsm

تفضل يمكنك استخدام هذه المعادلة =INDEX($C$5:$C$13,MATCH(K6,$G$5:$G$13,0)) وشرح المعادلة داخل الملف مثال.xlsx

تفضل 2أوفيسنا.xlsx

طبعا يمكن العمل فى كل صفحة ولكن لابد من ربطه بزر Sub Test() 'بداية الكود Dim LR As Long 'تحديد LR كمتغير الى اخر سطر به بيانات LR = Range("C" & Rows.Count).End(xlUp).Row Range("E1:E" & LR) = Evaluate("C1:C" & LR & "*D1:D" & LR) 'حاصل ضرب العمود C مع العمود D 'واخراج الناتج فى العمود E End Sub 'نهاية الكود

أهلا بك اخى الكريم فى المنتدى يمكنك استخدام خاصية البحث فى المنتدى

وعليكم السلام بالملف موجود كود لحاصل ضرب العمودان C & D واخراج الناتج فى العمود E Sub Test() Dim LR As Long LR = Range("C" & Rows.Count).End(xlUp).Row Range("E1:E" & LR) = Evaluate("C1:C" & LR & "*D1:D" & LR) End Sub كود ضرب.xlsm

تفضل Tab_Ali.xlsx

يمكنك التغيير كما تشاء فى المعادلة الى اى تاريخ تريد وبالنسبة لعلامة السالب يمكنك حلها ببساطة بضرب الناتج فى *-1

وعليكم السلام اهلا بك فى المنتدى-تفضل Tab_Ali.xlsx

بارك الله فيك والحمد لله الذى بنعمته تتم الصالحات

تفضل طبعا هيشتغل الضغط على الإنتر بدلا من الزر2.xlsm

يعمل معى كما ترى بالصورة 5الاستيك.rar

تفضل

من فضلك حدد بالضبط ما يحدث معك بالصور على الملف فالملف يعمل معى تمام

لأنك لم تقم بضبط تنسيق الخلية التى بها جملة السن فى 01/10/2019 كما بالصورة كان عليك من البداية رفع الملف الأصلى للعمل عليه تفضل اجهزه2.xlsm

تفضل لك ما طلبت -كما انه تم ضبط كود الإدخال والترحيل الى الشيت الضغط على الإنتر بدلا من الزر.xlsm

تفضل لك ما طلبت وضعت كود لطباعة كل الإستمارات استمارة متابعة حفظ.xlsm

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