ياسر خليل أبو البراء

أخي الكريم ابن الملك عوداً حميداً .. لقد اشتقنا إليك ولمشاركاتك الرائعة والقيمة بارك الله فيك على الموضوع الجميل .. في الحقيقة في بداية الأمر لم أفهم الملف ثم قمت بالإطلاع على الأكواد لأعرف ما يحدث فوجدت العجب العجاب .. :) وفي الحقيقة أعجبتني فكرة الملف ونظرت نظرة مدقق ووجدت أن الأمر أيسر من كل ذلك .. لما كل هذه الموديولات والأكواد واستخدام الـ Selection العديد من المرات .. واستخدام عمود مساعد لابجاد التاريخ المطابق للتاريخ الموجود في الخلية H2 (وعامل إخفاء قال يعني فيه حاجة بتخفى علينا في الإكسيل :) ) المهم هديتي لك بمناسبة رجوعك للمنتدى كود واحد وبس .. لكل الأزرار الثلاثة (شاي وقهوة ومية .. بس متنسانيش بإزازة حاجة ساقعة .. صفرا إذا أمكن) المهم الكود بالشكل التالي Sub Tea_Coffee_Water_Proc() 'Author : YasserKhalil 'Release : 18 - Aug. - 2016 '-------------------------- Dim Obj As Object Dim iCol As Long Dim Rng As Range Dim strDate As Date Dim iRow As Long Application.ScreenUpdating = False With Sheets("Sheet1") 'Get Column Number For Form Button Set Obj = .Buttons(Application.Caller) iCol = Obj.TopLeftCell.Column 'Get Row Number For Date strDate = CLng(.Range("H2").Value2) Set Rng = .Columns(3).Find(What:=strDate, LookIn:=xlValues) If Not Rng Is Nothing Then iRow = Rng.Row 'The Mission .Cells(iRow, iCol).Value = .Cells(iRow, iCol).Value + 1 .Cells(.Cells(Rows.Count, iCol).End(xlUp).Row, iCol).Select End With Application.ScreenUpdating = True End Sub فكرة الكود بتعتمد على إني بعرف رقم العمود المطلوب العمل عليه من خلال زر الأمر .. المرسوم في الخلية (شاي - قهوة - مياة) وبعد كدا بجيب رقم الصف بالاعتماد على البحث ولكن بالأكواد .. وموضح دا في التعليقات (التعليقات بالإنجليزي عشان محدش يفهمني غلط) وأخيراً تقدر تضع القيمة المطلوبة وهي زيادة مقدار الخلية بمقدار واحد من خلال سطر واحد .. وفي النهاية يتم تحديد آخر خلية في نفس العمود أرجو أن يكون الكود مفيد ومختصر .. تقبل وافر تقديري واحترامي

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

أخي الكريم اطلع على الموضوع التالي عله يفيدك الرابط من هنا

الحمد لله الذي بنعمته تتم الصالحات .. واصل معنا وستكتشف المزيد والمزيد تقبل تحياتي

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

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

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

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

للمزيد حول الموضوع يرجى زيارة الرابط التالي من هنا

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

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

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

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

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

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

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

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

وعليكم السلام أخي الكريم اللي مش عارف اسمه جرب تنسق الخلايا بتنسيق نص أولاً قبل عملية النسخ للأرقام وعند لصق الأرقام استخدم خاصية اللصق الخاص كقيم Paste As Values تقبل تحياتي

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

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

بارك الله فيك أخي الكريم سليم إثراءً للموضوع إليك دالة للراحل رحمه الله وأسكنه فسيح جناته (عماد الحسامي) توضع الدالة المعرفة في موديول Function VLOOKUPTwo(lookupValue1 As Variant, tableArray As Range, lookupValue2 As Variant, Col_index_num As Integer) Dim Rw As Long VLOOKUPTwo = "#N/A" For Rw = 1 To tableArray.Rows.Count If tableArray.Cells(Rw, 1).Value = lookupValue1.Value And tableArray.Cells(Rw, 2).Value = lookupValue2.Value Then VLOOKUPTwo = tableArray.Cells(Rw, Col_index_num).Value Exit Function End If Next Rw End Function لتطبيق الدالة قم بوضع المعادلة التالية في الخلية J9 =VLOOKUPTwo(H9,$A$2:$C$12,I9,3) حيث البارامتر الأول هو الشرط الأول .. يليه النطاق الذي يحتوي البيانات .. يليه الشرط الثاني ثم أخيراً رقم العمود المراد جلب البيانات منه تقبل تحياتي

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

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

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

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