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

أخي الكريم الدهشوري قمت بالبحث عن الدالة المعرفة وقمت بعمل معادلة لتناسب طلبك .. أرجو أن يفي الملف المرفق بالغرض إن شاء الله 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

السلام على حميع الاخوة الافاضل صحيح ان الاكسل بحر كلما علمنا شئ غابت عنا اشياء اساتذتي الافاضل عندي ملف للاستاذ عمر الحسيني فيه كود يقوم بالقص و النسخ مختصر و رائع و لكن الاشكال عندما جئت لتنفيذه على ملفي لم اعرف اين السر فقد جربت كل الطرق و عدلت في الخلايا و طبقت الملف نفسه مع زيادة في الاعمدة و لكن كان الفشل السمة الغالبة على عملي خاصة واني لا اساوي شئ امام عمالقة هذا المنتدى فكل استاذ يعتبر مدرسة قائمة بذاتها وكل كود ينسينا في الكود الذي بعده ...ولم اعرف ما السبيل اساتذتي ارجو تطبيق ملف الاستاذ عمر على ملفي خاصة وان عملي بقي فيه تطبيق هذا الكود فقط ...شكرا مسبقا لكم على مساعدتكم وتقبلو مني فائق عبارات الاحترام و التقدير: ملف الاستاذ عمر : Omar_1.rar وهذا ملفي ..ملف التلميذ حذف و لصق في صفحة ثانية.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))

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

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

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

ضع العبارة بعد الحلقة التكرارية وجرب بنفسك ..!!

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

ضع السطر التالي قبل سطر الخطأ On Error Resume Next

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

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

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

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

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

انا ساشارك مجاراة مع الموضوع الاصلي حتى لو انه منطقيا فقط في حالة ان الترقيم لن يتعدى خمس خانات بعد كود السنة اي فرضا لو وصل الترقيم 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

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

جزيت خيراً أخي الكريم زياد على دعواتك الطيبة المباركة .. وإن كنت لا أحب تداخل الموضوعات (لأن الطلب لا يخص الموضوع الحالي) ولكني سأجيبك باختصار أنه يمكن وضع الكود في حدث تغيير ورقة العمل Worksheet_Change وليس حدث تحديد خلايا ورقة العمل Worksheet_SelectionChange ... إذا التبس عليك الأمر فقم بطرح الطلب في الموضوع الخاص به لكي لا يحدث تداخل ... المهم الآن أن الموضوع الحالي قد تم حله بعون الله ... تقبل تحياتي

مشكور اخي ياسر على هذه الملاحظة القيمة تم التعديل على الكود المذكور الترحيل حسب الموقع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

وعليكم السلام أخي الكريم أبو يحيى حدد الخلايا المراد تغيير التنسيق لها ثم كليك يمين ثم اختر Format Cells ثم اختر أول خيار في القائمة في جهة اليسار والمسمى General

بارك الله فيك أخي العزيز جلال وجزاك الله خيراً .. ولأخونا رجب بمثل ذلك عسى أن يكون عدم دخوله للمنتدى خير إن شاء الله (افتقدناه كثيراً وافتقدنا روائعه)

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

السلام عليكم فورم لحفظ نسخة من الملف بامكانية تغيير اسم الملف والمسار يعمل على اكسل 2003-2007 افتراضيا يعطيك نفس مسار الملف مع نسخة بتاريخ اليوم واذا تكرر الخفظ يخفظ فوق النسخة المحفوظة لتاريخ اليوم اما اليوم الثاني ستكون لك نسخة اخرى بتاريخه وبعدين لك الحرية في كل الاستخدمات اذا لم تريد ذلك تغيير المسار تعيير الاسم كما تريد وفيه امكانيات ستعجبكم كثيرا هديتي لكم لان كنت مقلا معكم هذه الايام فورم لحفظ نسخة من الملف.rar

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

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

السلام عليكم ممتاز اخي العزيز خبور و انا كملت نسخة مع اضافة الالغاء للصف ولكن برسالة تحذيريه وبه بعض الافكار جديدة من الافضل التجربه خالص تحياتي Dinamic_Lable_last.rar

السلام عليكم تواصلاً للفكرة الجميلة للاخ عادل تفضلوا المرفق تحياتي لجميع المشاركين حفظهم الله ______________.rar