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

بسم الله الرحمن الرحيم الاخوة الكرام السلام عليكم ورحمة الله وبركاته برنامج الجمعيات الخيرية لبحث الحالات قمت يتصميم هذا البرنامج المتواضع منذ حوالي 3 سنوات تقريبا لجمعية خيرية واحببت ان اضعه بين ايديكم ليستفيد منه من يبحث عن برنامج مماثل البرنامج بسيط ان شاء الله وسهل التعامل معه أ - يجب ادخال الاكواد الاساسية اولا 1 - الحالات الاجتماعية ( اعزب - مطلق - ارمل ... الخ ) 2 - الحالة الصحية ( معاق - مريض بـ - شلل ... الخ ) 3 - المناطق ( منطقة شبرا - منطقة - ببولاق - منطقة العتبة ... الخ ) 4 - المتابعين ( المتابعين للحالة والقائم على زيارتهم وتفقده احوالهم ) 5 - نوع التبرع ( هل الحالة تستحق تبرع شهري او اقل او اكثر )\\ ب - تسجيل الحالات ج - تعديل حالة د - البحث عن حالة او طباعتها البرنامج مفتوح المصدر ويمكن التعديل عليه بما يناسب الحالة التي تمر عليك ارجو من الله العلي القدير ان يكون هذا العمل مقبولاً لوجهه الكريم SocialAffairs.rar تحياتي

واياكم اخى فايز وفيكم بارك الله اخى @فايز.. افضل اجابه لاخى واستاذى @kanory جزاه الله خيرا 💐

تم معالجة الأمر فقط استبدال ollsheets بـــ ALL (في القوائم المنسدلة) takrir yara_with ALL.xlsm

جرب المرفق دمج عمودين على التوالى (1).xlsx

جرب هذا الملف Aobu_yehya.xlsx

لاتعتذر استاذي الكريم مرورك على سؤالي كرم كثير

يمنكك تجربة هذا الملف (صفحة Salim) Option Explicit Sub All_in_One() Dim S As Worksheet Dim Rg_A As Range, Rg_D As Range Dim i%, m%, La%, LD% Dim Obj_Num As Object, Obj_Text As Object Set S = Sheets("Salim") S.Range("I2").Resize(1000).Clear La = S.Cells(Rows.Count, 1).End(3).Row LD = S.Cells(Rows.Count, 4).End(3).Row Set Obj_Num = CreateObject("System.collections.Arraylist") Set Obj_Text = CreateObject("System.collections.Arraylist") For i = 2 To La If S.Cells(i, 1) <> vbNullString Then If IsNumeric(S.Cells(i, 1)) Then Obj_Num.Add S.Cells(i, 1).Value Else Obj_Text.Add S.Cells(i, 1).Value End If End If Next '+++++++++++++++++++++++++++++ For i = 2 To LD If S.Cells(i, 4) <> vbNullString Then If IsNumeric(S.Cells(i, 4)) Then Obj_Num.Add S.Cells(i, 4).Value Else Obj_Text.Add S.Cells(i, 4).Value End If End If Next If Obj_Num.Count Then Obj_Num.Sort End If If Obj_Text.Count Then Obj_Text.Sort End If m = 2 If Obj_Num.Count Then S.Cells(m, "i").Resize(Obj_Num.Count) = _ Application.Transpose(Obj_Num.toarray) S.Range("I2").Resize(Obj_Num.Count) _ .Interior.ColorIndex = 35 m = m + Obj_Num.Count - 1 End If If Obj_Text.Count Then S.Cells(m, "i").Resize(Obj_Text.Count) = _ Application.Transpose(Obj_Text.toarray) S.Cells(m, "i").Resize(Obj_Text.Count) _ .Interior.ColorIndex = 40 m = m + Obj_Text.Count - 1 End If With S.Range("i2").Resize(m - 1) .Borders.LineStyle = 1 .Font.Size = 14: .Font.Bold = True .InsertIndent 1 End With End Sub الملف مرفق (الصفحة Salim) ABOU_Yahya Two_in_One.xlsm

جربي هذا الماكرو Option Explicit Dim Main As Worksheet Dim sh As Worksheet Dim max_ro%, i%, col, arr(), m% Dim st$, Ro%, k%, s#, x%, itm Dim date1 As Date, date2 As Date '======================= Sub Initiallize() For Each sh In Sheets If sh.Name <> "TAkrir" Then sh.Range("C5:J500").Interior.ColorIndex = xlNone End If Next End Sub Sub Extract_negative() Set Main = Sheets("TAkrir") Main.Range("B3:B8").ClearContents If Main.Range("B2") = vbNullString Then Exit Sub If Not IsDate(Main.Range("E3")) Or _ Not IsDate(Main.Range("F3")) Then Exit Sub Set sh = Sheets(Main.Range("B2") & "") date1 = Application.Min(Main.Range("e3:f3")) date2 = Application.Max(Main.Range("e3:f3")) ReDim arr(1 To 6) For i = 3 To 8 arr(i - 2) = Main.Cells(i, 1) Next max_ro = sh.Cells(Rows.Count, 1).End(3).Row k = 3 For Each itm In arr For x = 5 To max_ro If sh.Cells(x, 1) >= date1 And sh.Cells(x, 1) <= date2 Then If sh.Cells(x, itm) > 0 Then sh.Cells(x, itm).Interior.ColorIndex = 35 End If s = s + IIf(sh.Cells(x, itm) < 0, _ sh.Cells(x, itm), 0) End If Next x Main.Cells(k, 2) = IIf(s = 0, "", s) s = 0 k = k + 1 Next itm End Sub '++++++++++++++++++++++++++++++++++ Sub Extract_Positive() Set Main = Sheets("TAkrir") Main.Range("C3:C8").ClearContents If Main.Range("C2") = vbNullString Then Exit Sub If Not IsDate(Main.Range("E3")) Or _ Not IsDate(Main.Range("F3")) Then Exit Sub Set sh = Sheets(Main.Range("C2") & "") date1 = Application.Min(Main.Range("e3:f3")) date2 = Application.Max(Main.Range("e3:f3")) ReDim arr(1 To 6) For i = 3 To 8 arr(i - 2) = Main.Cells(i, 1) Next max_ro = sh.Cells(Rows.Count, 1).End(3).Row k = 3 For Each itm In arr For x = 5 To max_ro If sh.Cells(x, 1) >= date1 And sh.Cells(x, 1) <= date2 Then If sh.Cells(x, itm) < 0 Then sh.Cells(x, itm).Interior.ColorIndex = 6 End If s = s + IIf(sh.Cells(x, itm) > 0, _ sh.Cells(x, itm), 0) End If Next x Main.Cells(k, 3) = IIf(s = 0, "", s) s = 0 k = k + 1 Next itm End Sub '++++++++++++++++++++++++++ Sub Get_all() Initiallize Extract_negative Extract_Positive End Sub الملف مرفق takrir yara.xlsm

تفضل ..... ka_Database3.accdb

رائع و خقيقة مهندس كنت افكر بهكذا معادلة و قد وجدتها قبلي

لا يوجد تعب يا اخي فكلنا اخوة وارجوا من الله ان تجد ما تبحث عنه جرب المرفق من جديد UP-TEST_chrt2.rar تحياتي

اخي الكريم قد اشرت لك في مشاركة سابقة انك استخدمت النسبة المئوية في الاستعلام فقد يظهر معك الناتج خطأ عموما ان شاء الله خير تم تعديل الاستعلام وباذن الله النتيجة مرضية x1: Nz(DSum("PAX_IN_ARA";"TBL_IN_ARA";"[FROM_IN_ARA]=" & [FROM_IN_ARA] & " And [DATE_IN_ARA] between#" & Format([forms]![open_report]![date1];"yyyy/mm/dd") & "#and #" & Format([forms]![open_report]![date2];"yyyy/mm/dd") & "#")) x3: Nz(DSum("SET_IN_ARA";"TBL_IN_ARA";"[FROM_IN_ARA]=" & [FROM_IN_ARA] & " And [DATE_IN_ARA] between#" & Format([forms]![open_report]![date1];"yyyy/mm/dd") & "#and #" & Format([forms]![open_report]![date2];"yyyy/mm/dd") & "#")) x5: Nz([x1])/Nz([x3]) UP-TEST_chrt2.rar تحياتي

ربما قد غيرت بعض الارقام حتى تظهر معي اكثر برجاء مراجعة الارقام مرة اخرى UP-TEST_chrt2.accdb تحياتي

تفضل اخي الكريم هذا الموضوع سيفيدك ان شاء الله تحياتي

تفضل اخي الكريم ارجوا ان يكون هو المطلوب UP-TEST_chrt2.accdb تحياتي

العفو اخى @محمد التميمي واياكم ان شاء الله بالتوفيق بارك الله فيك اخى واستاذى @husamwahab وجزاك الله خيرا 💐

نعم اخي العزيز الخطا مني لاني تعاملت معه كنص وليس تاريخ اعتذر منك اخي العزيز

شكرأ استاذي الفلاحجي هذا هو المطلوب اللهم يزيدكَ علماً وتقوى وورع

مشاركه مع اخى واستاذى @husamwahab جزاه الله خيرا اتفضل حاجه على قدى ان شاء الله تكون ما تريد 33.accdb

اجعل حقلي key and datee في جدول Speer كمفتاحين رئيسيين

تفضل BOOK--Excel.xlsm

يمكنك عمل ذللك بـ: nested if و لكن عند اضافة الشيتات تضظر دائما اللى تغييير المعادلات باضافة الاوراق الجديدة كما أانه في حال بيانات كثييرة تكون الاستتجابة بظيئة. تفضل هدا الكود اسرع و يعمل مهما اضفت من صفحات جديدة. ضع فقط الارقام التي تريد في العمود A في ششيت البحث ثم اضغط جلب. Sub bring() Dim ash As Worksheet Dim sh As Worksheet Dim cell As Range Dim lrw As Integer Set ash = Sheets("search") ash.Range("b2:e1000").ClearContents For Each sh In ThisWorkbook.Sheets If sh.Name <> ash.Name Then For Each cell In sh.Range("a2:a1000") lrw = ash.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lrw If cell = ash.Cells(i, 1) Then ash.Cells(i, 2) = cell.Offset(, 1) ash.Cells(i, 3) = cell.Offset(, 2) ash.Cells(i, 4) = cell.Offset(, 3) ash.Cells(i, 5) = cell.Offset(, 4) End If Next i Next cell End If Next sh End Sub جلب بيانات من الشيتات.xlsb

أحسنت أخي @الفلاحجى راح بالي عنها .. جزاك الله خيرا وبارك فيك ..

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

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم الحاق.rar تحياتي

بالننسبة لاستثناء اوراق معينة ييمكنك االتغيير فيي كود listbox click الى هدا الكود Private Sub ListBox1_Click() If ListBox1.ListIndex > -1 Then Sheets(ListBox1.Value).Activate If Sheets(ListBox1.Value).Name <> "ورقة1" And Sheets(ListBox1.Value).Name <> "وررقة2" And Sheets(ListBox1.Value).Name <> "ورقة3" Then Sheets(ListBox1.Value).Range("d5") = Sheets("ورقة1").Range("f1") Sheets(ListBox1.Value).Range("d5").Select End If End If End Sub نموذج الملف (1) (1).xls

في هذه الحالة الكود افضل ما يمكن

ملف الكليندر غير موجدود عندي

هو صعب جداً حذف Oll sheets من القوائم المنسدلة ؟؟؟؟ اصلاً ضعي الاوراق التي تريدين التعامل معها في القوائم المنسدلة

اخي الكريم ... الامر بسيط حول حقل t1 الى رقم واجعله مطلوب فقط وجرب واعلمنا بالنتجة ... لاني اجيبك من خلال الموبايل

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

تم التصحيح .الكود يعمل الخطأ في الخلايا المدمجة. قاعدة.xlsm

ماشاء الله تبارك الله عمل جميل ومتميز وشاهدت فيديو العرض كاملا وبكل صدق اعجبني العمل ربما تكون ملاحظتي على استخدام الالون لبعض الحقول وهي لا تعيب العمل وانما رأي شخصي مع تمنياتي لك بالتوفيق بخصوص تسعير العمل الاخوان @محمد أبوعبدالله و @alaa aboul-ela ماقصروا وكتبوا كل ماكنت اود قوله

شكرا استاذ خالد

تفضل اخي الكريم TEST_chrt2.accdb حدد التاريخ في النموذج ولا تلتزم بحقل العام الحالي او العام الماضي يمكنك تغيير التاريخ وعرض التقرير حسب التاريخ المحدد ان شاء الله تحياتي

نشكر جهدك

وعليكم السلام ورحمة الله وبركاته هذه تجربة ارجوا انم يكون بها طلبك TEST_chrt2.rar تحياتي

تتفضل. الكود يعمل 100/100 بعد التعديل. تم التجربة Sub Button3_Click() Dim OutApp As Object Dim OutMail As Object For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With OutMail .To = Range("A" & i).Value .CC = Range("B" & i).Value .Subject = Range("C" & i).Value .HTMLBody = Range("D" & i).Value .Send End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing MsgBox Range("A" & i).Value Next i End Sub إيميللات (1).xlsm

من بعدك أستاذنا ومنكم نتعلم، وعلى خطاكم نسير

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

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

وعليكم السلام -تفضل ملف قيم لما تريد List All files from Folder and Sub-folders in Excel Workbook File_Manager.xlsm وهذا ملف اخر Open Excel files in a folder [VBA] List-all-files-in-a-folder.xlsm وهذا الرابط من داخل المنتدى أيضاً سيفيدك للأستاذ محمد صالح شرح عرض جميع الملفات والمجلدات في مسار list all files and folders in path في vba

السلام عليكم ورحمة الله استخدم هذا الكود Sub SelCase() For i = 7 To 1000 If Not IsNumeric(Cells(i, "EU")) Then Cells(i, "DS") = Cells(i, "EU") ElseIf Cells(i, "FO") = 0 Then Cells(i, "DS") = "ناجح" ElseIf Cells(i, "FO") <= 2 Then Cells(i, "DS") = "دور ثان" Else Cells(i, "DS") = "راسب" End If Next End Sub

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

السلام عليكم ورحمة الله وبركاته تناولت فى الفترة الماضية مايأتى حماية للشيت ما عدا نطاق محدد أو Protect Sheet Expect Range على الرابط http://www.officena.net/ib/topic/64169-حماية-للشيت-ما-عدا-نطاق-محدد-أو-protect-sheet-expect-range/ حماية كل أوراق العمل ما عدا نطاقات محددة أو Protect All Sheets Expect Ranges على الرابط http://www.officena.net/ib/topic/64193-حماية-كل-أوراق-العمل-ما-عدا-نطاقات-محددة-أو-protect-all-sheets-expect-ranges/ واليوم أقدم لكم حماية تلقائية للبيانات بمجرد فتح الملف لكل أوراق العمل مع استثناء نطاقات محددة قابلة لتعديل البيانات بها و بكلمة سر كلمة السر هى unloock ( ممكن تغييرها من الكود ) وهذا بناء على طلب أخونا وائل الأسيوطى الكود وعليه الشرح Dim sh As Worksheet Private Sub Workbook_Activate() ' Auto Protect Workbook Expect Ranges ' by mokhtar 25/10/2015 With Application .DisplayAlerts = False ' تعطيل التنبيهات .ScreenUpdating = False ' تعطيل تحديث الشاشة For Each sh In Worksheets ' لكل شيت فى الاوراراق If sh.ProtectContents = True Then ' اذا كان الشيت محميا فان ' لا تفعل شيئا Else ' واذا لم يكن محميا sh.Protect ' اجعل الشيت محميا End If ' انهاء الشرط Next sh ' الشيت التالى ActiveWorkbook.Save ' حفظ .DisplayAlerts = True ' اعادة تشغيل التنبيهات .ScreenUpdating = True ' اعادة تشغيل تحديث الشاشة End With End Sub Private Sub Workbook_Open() With Application .DisplayAlerts = False ' تعطيل التنبيهات .ScreenUpdating = False ' تعطيل تحديث الشاشة On Error Resume Next ' فى حالة حدوث خطأ تجاهله وانتقل للأمر التالى ' حلقة تكرارية للتعامل مع كل شيت فى الملف For Each sh In Worksheets ' اذا كانت محتويات الشيت محمية فان If sh.ProtectContents = True Then ' اجعل الشيت غير محمياً sh.Unprotect ' حلقة تكرارية لحذف جميع النطاقات المسموح يتعديلها فى الشيت For i = 1 To sh.Protection.AllowEditRanges.Count Debug.Print sh.Protection.AllowEditRanges(i) sh.Protection.AllowEditRanges(i).Delete Next i ' انهاء الحلقة التكرارية ' اضافة النطاقات المسموح بتعديلها أثناء حماية الشيت Sheets("Sheet1").Protection.AllowEditRanges.Add Title:="mokhtar1", Range:=Range("A18:G29"), Password:="unloock" ' اضافة النطاق فى الورقة الاولى Sheets("Sheet2").Protection.AllowEditRanges.Add Title:="mokhtar2", Range:=Range("F6,H7,D8,F14,H14"), Password:="unloock" ' اضافة النطاق فى الورقة الثانية Sheets("Sheet3").Protection.AllowEditRanges.Add Title:="mokhtar3", Range:=Range("D2,F3,D6,B8,F11,B14,D14"), Password:="unloock" ' اضافة النطاق فى الورقة الثالثة Sheets("Sheet4").Protection.AllowEditRanges.Add Title:="mokhtar4", Range:=Range("F10:F23"), Password:="unloock" ' اضافة النطاق فى الورقة الرابعة Else sh.Protect End If ' انهاء الشرط Next sh ' انهاء الحلقة التكرارية .DisplayAlerts = True ' اعادة تشغيل التنبيهات .ScreenUpdating = True ' اعادة تشغيل تحديث الشاشة End With End Sub المرفق للتجربة تحياتى والسلام عليكم Auto Protect Workbook Expect Ranges By Mokhtar.rar

الأخ الحبيب سليم بارك الله فيك بعد إذنك جرب الكود التالي .. Sub LoopThroughSheets() Dim rNumber As Long, I As Long, X As Long 'عدد مرات التكرار rNumber = 2 'بداية الثواني X = 10 For I = 1 To rNumber 'حلقة تكرارية لأوراق العمل For II = 3 To 5 Application.Wait (Now + TimeValue("0:00:" & X)) X = X + 5 Sheets(II).Select Next II X = 10 Next Sheet1.Activate End Sub

اليك هذا النموذج لعله المطلوب تحديد حسب الوقت.rar