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

ممكن التعامل مع هذا الملف واختيار 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

السلام عليكم لدى قاعدة بيانات بها اسماء عاملين والمطلوب عمل تقرير بالاسم والقسم بناء على ترتيب الاقسام فى الشركة لذلك قمت بعمل حقل اسميته print كتبت به رقم الموظظف الذى اريده فى التقرير المطبوع وذلك بناء على الاقسام فى الشركة وهى كالتالى 1- معدات 2- مبانى 3- علاقات 4- تخطيط 5- خدمات وعندما صممت التقرير واقوم بعمل تجميع حسب القسم لا اعلم لماذا يتم عرض الاقسام حسب الترتيب الابجدى مرفق قاعدة بيانات والترتيب تم كتابته فى التقرير n15.accdb

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

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

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

@MTGFM فكرة جميلة

اتفضل sa.rar

الف شكر

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

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

تفضل دليل الهاتف - Copy.xlsm

تفضل أتمنى ان يكون المطلوب ترتيب3.xlsm

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

تفضل اخى الكريم نفس ملف استاذنا الكريم سليم وتم تعديل المطلوب protect first column.xlsm

ولكى يعمل هذا الكود معك فى كل صفحة جديدة تفتحها داخل الملف لابد من وضع هذا الكود فى حدث This WorkBook Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Call Test End Sub كود ضرب.xlsm

تفضل 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 'نهاية الكود

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

تفضل Tab_Ali.xlsx

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

تفضل نفس كود استاذنا الكبير سليم له منا كل المحبة والإحترام frais de miss ion 019.xlsm

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

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

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

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

تفضل

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

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

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

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

بعد اذن استاذنا الكبير سليم هذه معادلة أخرى لإثراء الموضوع أوفيسنا.xlsx

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