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

أخي الكريم الدهشوري قمت بالبحث عن الدالة المعرفة وقمت بعمل معادلة لتناسب طلبك .. أرجو أن يفي الملف المرفق بالغرض إن شاء الله Days Tafkeet.rar

بعد اذن الاخوة تفضل هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 3 Then On Error Resume Next Dim myrg As Range Set myrg = ورقة1.Range("A1:B100") Target.Offset(, 1).Value = "" Target.Offset(, 1).Value = Application.WorksheetFunction.VLookup(Target.Text, myrg, 2, 0) End If End Sub اما بخصوص كود اخي الغالي ابو البراء قم بتعديل من Sheet1 الى ورقة 1 داخل الكود حسب الموجود لديك

ياما في الجراب يا حاوي .. كله بفضل الله عزوجل .. لدي مكتبة تجميعية لعدد كبير من الأكواد أطوعها في تلبية الطلبات بحيث تلبي جميع الاحتياجات وافر تقديري واحترامي

وإثراءً للموضوع هذا كود آخر كنت قد جهزته وانتظرت أن يصل أخي وحبيبي سليم لخط النهاية قبلي .. الكود يوضع في موديول عادي Sub TransferData() Dim DictPerson As Object, DictSheet As Object, rng As Range, mtx(), isFound As Boolean Dim I As Long, v1 As Variant, v2 As Variant Application.ScreenUpdating = False Set rng = Sheets("Tafasil").Range("A1:O" & Sheets("Tafasil").Cells(Rows.Count, "O").End(xlUp).Row) mtx = rng.Value Set DictPerson = CreateObject("Scripting.Dictionary") For I = 2 To UBound(mtx, 1) If Not DictPerson.Exists(mtx(I, 15)) Then DictPerson.Add mtx(I, 15), mtx(I, 15) Next I Set DictSheet = CreateObject("Scripting.Dictionary") For I = 1 To Worksheets.Count If Not DictSheet.Exists(Worksheets(I).Name) Then DictSheet.Add Worksheets(I).Name, Worksheets(I).Name Next I DictSheet.Remove ("Tafasil") For Each v1 In DictPerson isFound = False For Each v2 In DictSheet If v1 = v2 Then isFound = True Exit For End If Next v2 If Not isFound Then If MsgBox(v1 & " Does Not Exist." & vbCrLf & "Create This Sheet ? ", vbOKCancel) = vbOK Then Worksheets.Add After:=Sheets("Tafasil") ActiveSheet.Name = v1 ActiveSheet.DisplayRightToLeft = True DictSheet.Add v1, v1 End If End If Next v1 For Each v1 In DictSheet Sheets(v1).Cells.Clear Sheets(v1).Range("A1").Resize(1, 4).Value = Array("الاسم", "الرقم", "الفرق", "الموقع") rng.AutoFilter field:=15, Criteria1:=v1 With rng.Offset(1) .Columns("A:B").SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("A2").PasteSpecial xlPasteValues .Columns(5).SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("C2").PasteSpecial xlPasteValues .Columns(15).SpecialCells(xlCellTypeVisible).Copy: Sheets(v1).Range("D2").PasteSpecial xlPasteValues End With With Sheets(v1) .Range("A1").CurrentRegion.Borders.Value = 1 .Range("A1").Resize(1, 4).Font.Bold = True .Cells.RowHeight = 19 .Cells.HorizontalAlignment = xlCenter: .Cells.VerticalAlignment = xlCenter .Columns(1).ColumnWidth = 18: .Columns("B:C").ColumnWidth = 10: .Columns(4).ColumnWidth = 13 End With Next v1 rng.AutoFilter Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub تقبل تحياتي

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

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

البساطة البساطة ياعيني عالبساطة شكرا أخ ياسر العربي كلامك صحيح , الحمدلله تم حل المشكلة كما ذكرت

الاخ صلاح الصغير شكرا لك اخي كلنا في خدمة الاخوة الاخ ياسر خليل أبو البراء سأحاول بأذن الله افضل داله في المجموعة والتي اعمل عليها دائما هي دالة ابو هاني AbuHani المثال رقم 11 او 13

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

الاخ ياسر خليل أبو البراء المرفق ليس به جديد سوي الاضافة التي اشرت اليها اما ملف دالة التفقيط الخاصة بالأخ هادي لدي ملف مجمع للمجموعة كامله التفقيط ###.rar

مرحبا بعد إذن أخي ياسر يمكن ان نستعمل الدالة التالية في الخلية D2 ونسحبها للأسفل =IFERROR(VLOOKUP(C2;المسافة!$A$1:$B$500;2;0);"")

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

وعليكم السلام أخي الكريم محمد جرب الكود التالي في حدث ورقة العمل المسماة "الجدول" كليك يمين على اسم ورقة العمل "الجدول" ثم اختر View Code والصق الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 2 And Target.Column = 3 Then Application.EnableEvents = False Dim iRow iRow = Application.Match(Target.Value, Sheet1.Columns(1), 0) If IsNumeric(iRow) Then Target.Offset(, 1).Value = Sheet1.Cells(iRow, "B").Value End If Application.EnableEvents = True End If End Sub تقبل تحياتي

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

بعد اذن اخي ابو البراء اخي ابو عيد قم بالغاء ارتباط المربع النصى وقم بالكتابة داخله هكذا 24 او لو الرقم موجود وعند الضغط عليه سيتحول تلقائي كما تريد ثم اعد ربط المربع النصي مرة اخرى بالخلية المطلوبة البساطة يااسيادنا هههههه

جميل ورائع أخي الحبيب سليم كمل جميلك .. عند عدم وجود ورقة عمل يتم إنشاء ورقة عمل جديدة ..هلا خيرت المستخدم إذا كان يريد ورقة العمل أم لا؟ وأمر آخر يتم نسخ كافة عناوين الحقول عند إنشاء ورقة عمل جديدة (لاحظ هذه النقطة) ملحوظة أخرى : إذا قمت بحذف كل أوراق العمل والإبقاء على الورقة الرئيسية ثم تنفيذ الكود لا يقوم بإنشاء أوراق العمل بشكل صحيح ويحدث خلل كبير .. تقبل وافر تقديري واحترامي

بارك الله فيك أخي سليم وجد حل عن طريق هذه الدالة =MOD(A1;1)=0 باستخدام طريقة التنسيق الشرطي وطبقتها على العامود A فقمت أولا بتنسيق العامود بالطريقة الطبيعية ووضع تنسيق عملة و 2 منزلة عشرية ومن ثم وضعت تنسيق شرطي عندما يتحقق هذا الشرط =MOD(A1;1)=0 يكون التنسيق عملة و0 عدد المنازل العشرية

مشكور اخي ياسر على هذه الملاحظة القيمة تم التعديل على الكود المذكور تم التعديل مرة اخرى بواسطة هذا الكود Sub CreateSheets() Dim ws As Worksheet Dim K As Range Dim ListSh As Range Application.ScreenUpdating = False With Worksheets("tafasil") Set ListSh = .Range("o2:o" & .Cells(.Rows.Count, "o").End(xlUp).Row) End With On Error Resume Next For Each K In ListSh Worksheets("tafasil").Activate If Len(Trim(K.Value)) > 0 Then y = Worksheets(Trim(K.Value)).Name t = Application.CountIf(Range("o2:o" & K.Row), Trim(K.Value)) If IsEmpty(y) And t = 1 Then Worksheets.add(After:=Worksheets(Worksheets.Count)).Name = K.Value ActiveSheet.Range("a1:d1") = Array("الاسم", "الرقم", "الفرق", "الموقع") '============================================ End If y = Empty End If Next K Application.ScreenUpdating = True Worksheets("tafasil").Select End Sub و تغيير مسح البيانات الى هذا الكود Sub del_data() For mh = 2 To Sheets.Count Sheets(mh).Range("A2:d5000").ClearContents Next Sheets("tafasil").Select Range("a2").Select End Sub و الكود النهائي الى هذا الكود Sub AddValues() Dim My_sheet As Worksheet Dim i As Single '============================= Application.ScreenUpdating = False CreateSheets answer = MsgBox("هل تريد مسح البيانات في الاوراق الباقية أولاً ", vbQuestion + vbYesNo + vbMsgBoxRtlReading) If answer = 6 Then del_data lr_MAIN = Sheets("tafasil").Cells(Rows.Count, 1).End(3).Row If lr_MAIN < 2 Then lr_MAIN = 2 For K = 2 To lr_MAIN '========================================== On Error Resume Next Set My_sheet = Sheets("" & Sheets("tafasil").Range("O" & K)) If Sheets("tafasil").Range("O" & K) = "" Then GoTo 1 '========================================== With My_sheet i = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Range("A" & i) = Sheets("tafasil").Range("A" & K) .Range("b" & i) = Sheets("tafasil").Range("b" & K) .Range("c" & i) = Sheets("tafasil").Range("e" & K) .Range("d" & i) = Sheets("tafasil").Range("O" & K) .Range("a2").Select End With '========================================== 1: Next Application.ScreenUpdating = True Sheets("tafasil").Range("a1").Select End Sub ليصبح الشكل النهائي للملف هكذا الترحيل حسب الموقعsalim2.rar

السلام عليكم ورحمة الله أخواني الكرام وعلمائنا وأساتذتنا العباقرة في هذا الصرح العملاق والأكثر من رائع بعد إنتهاء ولله الحمد من برمجة برنامج شؤون الموظفين والمرتبات ونشره في الموقع منذ فترة وجيزة على هذا الرابط برنامج شؤون وإدارة الموظفين بحلته وشكله الجديد أحببت اليوم بعد طلبات من الاصدقاء أن أقوم برفع البرنامج مفتوح المصدر لكي تتم الفائدة منه في كافة النواحي العلمية والعملية وذلك من (خلال الكودات وطريقة التصميم) ماعليكم سوا فك الضغط عن الملف المرفق وتنصيب البرنامج بكل سهولة وفي الاخير تفعيل الماكرو يعمل البرنامج على كافة أنظمة ويندوز وكافة نسخ أوفيس من 2007 ومافوق لاتنسونا من الدعاء بظهر الغيب في هذه الايام المباركة الملف بامتداد zip هو الملف كاملا Office Soft.Employ & Salary-Source.zip Office Soft.Employ _ Salary-Source.rar

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

صحيح كان الاولى التجربة حتى نختصر الوقت والجهد تفضل اخي الحبيب Private Sub Form_BeforeInsert(Cancel As Integer) On Error Resume Next Dim xLast, xNext As Integer Dim prtyr, prtTxt As Integer prtyr = Right(DatePart("yyyy", Date), 2) prtTxt = CLng(Mid(DMax("ID", "tbl1"), 2, 2)) xLast = CLng(Right(DMax("ID", "tbl1", prtTxt = prtyr), 5)) If IsNull(xLast) Then xNext = 1 Else xNext = xLast + 1 End If Me!ID = "S" & prtyr & Format(xNext, "00000") End Sub ترقيم مع السنة وزيادة حرف.rar

عزيزى السائل اليك كرت دوام قمت بتنفيذه من خلال ما تعلمته من هذا الصرح العمـــلاق اتمنى ان يلبى طلبك ... وللعلم منقول ... مع بعض التعديل عليه -- عليك كتابة الشهر بهذة الطريقة 1/2/2016 سيتغير معك التاريخ واليوم للشهر كامل -- باسورد الخلايا 1234 كرت دوام.rar

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

شكرا يا زعيم انت دائما في الموعد ،، ربنا يبارك فيك.

هو انت فين مخبي الحاجات دي كلها

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

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

مين الجراح اللي عمل العملية ؟؟ أكيد إنت !! أنا عطيتك المشرط وإنت قمت بالعملية .. تسلم يا دكتور زيزو

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

تم التعديل مرة ثالثة الترحيل حسب الموقعsalim3.rar

أستاذنا الفاضل / ياسر خليل أبو البراء أنا آسف جدااااااااااااااااااااااااا ..... يمكن مقصدش ..... ولا من طبيعتى أن أقوم بالرد عن طريق الإحباط ..... فأكرر اعتذاري للمرة الأولى والأخيرة لشخصكم الكريم + شخص أستاذنا الفاضل / زيزو العجوز آسف جداااااااااااااااااااااااااااا

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

1-انسخ هذه المعادلة الى الخلية J9 2- اضغط (Ctrl+Shift+Enter) 3-اسحب المعادلة الى باقي الصفوف =INDEX($C$2:$C$12,MATCH(H9&I9,$A$2:$A$12&$B$2:$B$12,0))

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

جزاك الله كل خير ورزقك من حيث لا تحتسب الطريقة هذه جداً ممتازهـ وسوف تساعدني بإذن الله وراح أجربها بالعمل :)

السلام عليكم ورحمة الله اليك الحل باذن الله شيت كنترول الصف الثاني والثالث الإبتدائي.rar

وهذا شرح توضيحي

ابو خليل جهاز الحضور موجود لكن الجهاز لا يحتسب الاجازات المؤقته لكن يحسب وقت دخول وخروج فقط للموظف ... اما الاجازات الزمنية فهذه تتم عن طريق الفورم الذي يقدمة الموظف عدد الساعات ووقت الخروج والرجوع.. دور الجهاز انه سوف يقرئ موعد خروج وعوده الموظف في الوقت المذكور وهل تأخر عن الموعد المذكور ام لا..

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

معذرة اخي محمد لم انتبه ان المسألة بحاجة الى تعديل آخر لاحظ السطر هذا الموجود في الكود xNext = Val(Mid(xLast, 3, 5)) + 1 فيه حاجة لازم تتغير في السطر اعلاه ، لأننا اضفنا حرفا الى الترقيم الذي هو حرف s فالرقم 3 يعني اننا سنبدأ العد من اليسار ابتداء من الحرف الثالث الى السابع ، ثم نضيف اليه واحد ولكن الحرف الثالث من اليسار في الكود الأصلي هو الرقم الذي يأتي بعد السنة ( التي هي رقمين ) ولكننا اضفنا حرف s قبل رقمي السنة لذا يجب ان نعدل الـرقم 3 الى 4 لكي نبدأ من الحرف ( او الرقم ) الرابع لذا يجب ان نعدل السطر المذكور ليصبح xNext = Val(Mid(xLast, 4, 5)) + 1 اعلم انه يكفيك الاشارة الى مكان الخلل ولكني تبسطت بالشرح لمن يأتي لاحقا

مبروك اخينا الكريم الوزير :: مثابر ومتابع ... لك مني الف تحية وتقدير

الاخ زياد777 شاهدالمرفق Omar_1.rar

اخي الكريم : ياسر ابو البراء السلام عليكم جزاك الله خيرا قراتها جيدا ونفذتها جيدا وذلك في بداية الموضوع ولكن بعد تطور الموضوع واستخدام دالة الأستاذ ( الشهابي ) قمت باستخدام ملف يقوم بتحويل الدوال لكي تعمل في الأكواد باسم ( محول الدوال السريع ) فغابت عني هذة النقطة ولم اراجع الدالة بعد تحويلها شكرا لك علي هذه الملاحظه الجميلة ...... التكرار يعلم ..... الشطار وشكرا لك علي اهتمامك بالموضوع واليكم الملف احصاء الصف الثاني العلمي.rar

انا ساشارك مجاراة مع الموضوع الاصلي حتى لو انه منطقيا فقط في حالة ان الترقيم لن يتعدى خمس خانات بعد كود السنة اي فرضا لو وصل الترقيم 1399999 اي هناك اكثر من تسعة وتسعون الف وتسعمائة وتسع وتسعون سجل في السنة سنة 2013 فماهي السياسة في الزيادة . فلو استمرينا باضافة 1 سيكون السجل التالي يبدا 14 ونحن مازلنا في نفس السنة . ولكن حسب رأي الاخ محمد سلامة بانه لن يحصل خلال السنة فهذا الكود سيعمل وبدون اللاحقة s . لكي يضل المحتوى نفس الموضوع. Private Sub Form_BeforeInsert(Cancel As Integer) If Right(Year(Date), 2) > Left(DMax("ID", "tbl1"), 2) Then xNext = Right(Year(Date), 2) & "00001" Else xNext = DMax("ID", "tbl1") + 1 End If ID = xNext End Sub

جزاكم الله خيراً ولاحظ أنه بعد تنفيذ الكود إذا تم مسح النطاقات تظل الأوراق الأربعة محددة ..!! وسؤال خطر ببالي : ماذا لو كان العمود O يحتوي على قيم ليس لها أوراق عمل ؟؟!! .. ما هو المطوب في هذه الحالة : أن يتم تخطي القيمة وتجاهلها أم يتم إنشاء ورقة عمل جديدة وتنقل إليها البيانات؟ أم يتم تخيير المستخدم فيما بين الأمرين؟

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

مشكور اخي ياسر على هذه الملاحظة القيمة تم التعديل على الكود المذكور الترحيل حسب الموقعsalim1.rar

جرب هذا الماكرو يعمل فقط على العامود A يمكن التغيير الى اي عامود (اعمدة تشاء) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And IsNumeric(Target) Then On Error Resume Next If Int(Target) = Target Then Target.NumberFormat = Selection.NumberFormat = "\$ 0" If Int(Target) <> Target Then Target.NumberFormat = "\$ 0.00" End If End Sub

وعليكم السلام ورحمة الله وبركاته أخي العزيز أنس دروبي بارك الله فيك وجزاك الله خيراً على هذا العمل المتميز ويسعدني أن أكون أول المهنئين لك على هذه التحفة الفنية * عند تجربة البرنامج وتنصيبه وعند النقر على "موظف جديد" .. عند محاولة الكتابة لا تتم الكتابة في صناديق النصوص تقبل وافر تقديري واحترامي

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