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

ممكن تتعب شوية وتقارن بنفسك حتى تتعلم Come easy Go easy

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

أخي ضع التنسيق المطلوب داخل ملف

أخي الكريم الطلب غير واضح هل تقصد بالتحديد التظليل أو التلوين كما بالملف المرفق ؟ أم تحديد الصف Select بشكل عادي ثانياً الخلايا المقصودة في العمود C فقط أم في أي عمود

هل تقصد أن يكون كل كود ترحيل منفصل ... كود ترحيل الناجحين منفصل عن كود ترحيل الراسبين ؟

أخي الحبيب أبو عبد الملك إليك الملف التالي قم بالتجربة وإعطاء الملاحظات ..فيما يخص هذا الطلب وليس طلب جديد أما لو طلب جديد اطرح موضوع جديد لاحظ معي حجم الملف وتابع حجم الملف أولاً بأول (56.6 كيلو بايت) Sub GetDataUsingFind() Dim shData As Worksheet, shRecord As Worksheet Dim Cell As Range Dim X As Long Set shData = Sheets("سجل القيد"): Set shRecord = Sheets("معلومات التسجيل") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With shRecord .Range("A2:A1000,C2:E1000,G2:G1000,I2:I1000").ClearContents For Each Cell In .Range("B2:B" & .Cells(.Rows.Count, 2).End(xlUp).Row) If Not shData.Columns("B:B").Find(Cell) Is Nothing And Not IsEmpty(Cell) Then X = Application.WorksheetFunction.Match(Cell, shData.Columns("B:B"), 0) Cell.Offset(, -1) = Cell.Row - 1 Cell.Offset(, 1) = shData.Cells(X, "C") Cell.Offset(, 2) = shData.Cells(X, "D") Cell.Offset(, 3) = shData.Cells(X, "E") Cell.Offset(, 5) = shData.Cells(X, "F") Cell.Offset(, 7) = shData.Cells(X, "I") End If Next Cell End With Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub تقبل تحياتي Quran School V1.rar

راجع رابط التوجيهاات سيتم حذف الموضوع بعد قليل

أخي الكريم يرجى تغيير اسم الظهور للغة العربية إليك الحيلة التالية لتحقيق مطلبك قم بإدراج معادلة في عمود مساعد جانب عمود الأرقام =RAND() ثم من خلال التبويب Data ثم الأمر Sort اختر الترتيب على أساس العمود الذي به الدالة يمكنك حذف العمود المساعد بعد الانتهاء من تحقيق مطلبك انتهى تقبل تحياتي Randomize Data.rar

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

أخي الحبيب القومي جزيت خير الجزاء على هذ الكود الرائع من روعة الكود وبساطته دفعني لشرح الأسطر لعله يفيد الأخوة الأعضاء خصوصاً العاملين في مجال التربية والتعليم قمت بتعديلات طفيفة على الكود (لعل الأمر لا يضايقك) إليكم الكود بالشرح Sub Nageh_Raseb() 'يقوم الكود بترحيل الناجحين والراسبين في أوراق العمل المخصصة لذلك '---------------------------------------------------------------- 'تعريف المتغيرات Dim RowNageh As Long, RowRaseb As Long Dim WS As Worksheet, SHNageh As Worksheet, SHRaseb As Worksheet 'تعيين متغيرات أوراق العمل Set WS = Sheets("الشيت"): Set SHNageh = Sheets("كشف ناجح"): Set SHRaseb = Sheets("كشف الدور الثاني") 'مسح محتويات النطاق الذي سيتم الترحيل إليه في ورقة الناجحين SHNageh.Range("C7:M1000").ClearContents 'مسح محتويات النطاق الذي سيتم الترحيل إليه في ورقة الراسبين SHRaseb.Range("C7:M1000").ClearContents 'صف البداية الذي سيتم الترحيل إليه في ورقة الناجحين وورقة الراسبين RowNageh = 7: RowRaseb = 7 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'حلقة تكرارية في ورقة البيانات الأساسية بداية من الصف رقم 11 حتى آخر صف For R = 11 To WS.Cells(Rows.Count, 1).End(xlUp).Row 'يمثل الرقم 113 رقم العمود الذي به النتيجة في ورقة البيانات الأساسية 'إذا كانت الخلية في الصف المحدد في عمود النتيجة تساوي كلمة ناجح If Cells(R, 113) = "ناجح" Then 'نسخ النطاقات المحددة في الصف المحدد في حالة تحقق الشرط WS.Range("A" & R).Range("B1:C1,Z1,AI1,AR1,BA1,BL1,BM1,CD1,DI1,DJ1").Copy 'لصق البيانات المنسوخة إلى العمود الثالث في ورقة الناجحين SHNageh.Range("C" & RowNageh).PasteSpecial xlPasteValues 'إلغاء خاصية القص والنسخ Application.CutCopyMode = False 'زيادة المتغير بمقدار واحد استعداداً لبيانات جديدة RowNageh = RowNageh + 1 'إذا كانت الخلية في الصف المحدد في عمود النتيجة تساوي كلمة دور ثان في ElseIf Cells(R, 113) = "دور ثان في" Then 'نسخ النطاقات المحددة في الصف المحدد في حالة تحقق الشرط WS.Range("A" & R).Range("B1:C1,Z1,AI1,AR1,BA1,BL1,BM1,CD1,DI1,DJ1").Copy 'لصق البيانات المنسوخة إلى العمود الثالث في ورقة الراسبين SHRaseb.Range("C" & RowRaseb).PasteSpecial xlPasteValues 'إلغاء خاصية القص والنسخ Application.CutCopyMode = False 'زيادة المتغير بمقدار واحد استعداداً لبيانات جديدة RowRaseb = RowRaseb + 1 End If 'الانتقال للصف التالي في ورقة البيانات الأساسية Next 'رسالة تفيد بانتهاء عملية الترحيل MsgBox ("الحمد لله تم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة"), vbInformation 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub الأخ الفاضل سامي طلبك غير منطقي وغير مفهوم ... أين تريد النتائج له دور ثان ولها دور ثان ..هل تقصد في الأوراق المرحل إليها أم تقصد أن ورقة البيانات الأساسية فيها عمود النتيجة بهذا الشكل الذي ذكرته وهل الترحيل للأولاد في ورقة عمل منفصلة عن الإناث أم ماذا ؟ وضح ربنا يبارك فيك ... طلب التوضيح متكرر معك بشكل خاص (إحنا مش عباقرة ولا مكشوف عننا الحجاب !! عشان نعرف كل واحد عايز ايه من غير ما يوضح) الرجاء التوضيح ثم التوضيح وبالتفصيل إذا أردت فعلاً المساعدة

أخي الكريم ياسر نوح وجب عليك التوضيح من البداية كما فعلت في المشاركة السابقة التوضيح والتفصيل للطلب يسهل الوصول لحل إذ أن الفكرة كيف لي أن أساعدك وأنا لا أفهم المطلوب ، ففهم المطلوب عليه عامل 90% من الوصول للحل ، حتى لو كان المطلوب صعب .. المهم إليك الكود التالي (طبعاً كما فهمت من الصورة ورقة العمل المطلوب الكود بها هي "توصيف رياضة") Sub M_ELSHRIEF() Dim Answer As Long, lCount As Long Answer = MsgBox("هل تود الطباعة بعد المعاينة ؟", vbYesNo + vbQuestion, "طباعة") If Answer = vbYes Then '[L2] حلقة تكرارية من 1 إلى 12 ليتم وضع قيم الحلقة في الخلية For lCount = 1 To 12 'بدء التعامل مع ورقة العمل النشطة With ActiveSheet .Range("L2").Value = lCount 'هذا السطر لمعاينة ورقة العمل النشطة '.PrintPreview 'طباعة ورقة العمل النشطة نسخة واحدة .PrintOut Copies:=1 End With Next lCount End If End Sub تقبل تحياتي

بسم الله ما شاء الله منور المنتدى والله ..ربنا يبارك فيك لا تحرمنا من وجودك ومن إبداعاتك .. تقبل ودي وحبي واحترامي وتحياتي

يرجي الالتزام بالتوجيهات

جرب الكود التالي. Sub ConvertItVBA() With Range("E2:E" & Cells(Rows.Count, 3).End(xlUp).Row) .Formula = "=IF(AND($C2<>"""",$D2<>"""",$C2=1,$D2=1),""sala"",IF(AND($C2<>"""",$D2<>"""",$C2=1,$D2=15),""retre"",""""))" .Value = .Value End With End Sub فقط حولت معادلة الأخ الحبيب سليم عذراً أخي سليم لم أرى مشاركتك إلا الآن

أخي وحبيبي في الله أسامة بارك الله فيك وجزاك الله خير الجزاء لا تحرمنا من إبداعاتك (يا ما في الجراب يا براوي) لو أمكن وضع الدوال المعرفة في مصنف إكسيل والتطبيق عليهما ليستفيد الأخوة الكرام من الموضوع أقصى استفادة تقبل تحياتي :fff:

أخي وحبيبي الغائب عن الأعين الحاضر في القلوب مختار حسين بوركت وجزيت خيراً وأكلت لحم طيرٍ وتزوجت بكراً (ربنا يستر وجماعتك ميشوفوش الدعاء ده ليدعوا عليا)

أخي الحبيب ومعلمي الكبير دغيدي بل أنتم الأصل وأنتم النجوم لنا بارك الله لنا فيكم وجزاكم الله خير الجزاء

بسم الله ما شاء الله أخي أسامة بارك الله فيك ملحوزة صغيرة .. متنساش تلغي اهتزاز الشاشة وخلافه حتى يستغرق الكود وقت أقل .. جرب الكودين هتلاقي حوالي ثانيتين أو تلاتة فرق .. طبعاً مع عدد المصنفات الكثيرة هيفرق حاجة تانية مع السطرين اللي بدايتهم xl0.Worksheets("المعلومات الأساسية") الأفضل نستخدم جملة With xl0.Worksheets("المعلومات الأساسية") End With أنا مش بعدل عليك ..أنا بس بفكر بصوت عالي عشان نوصل لأفضل الحلول .. يداً بيد نبني قلعة الأكواد الحصينة ( YK & OB) :fff:

ممكن تكتب الشكل النهائي للتنسيق المطلوب عشان يكون واضح

أخي الفاضل لم تغير اسم الظهور للغة العربية بالنسبة للتعديل أبسط مما تتخيل روح للخلايا اللي أشرت إليها في المشاركة رقم 4 وغير الرقم 30 إلى الرقم الأخير في البيانات ومتنساش تضغط Ctrl + Shift + Enter حاول وافضل حاول .. ولا تكف عن المحاولات .. وافشل يكفيك شرف المحاولة الأخ الحبيب علاء رسلان .. إحنا غلابة لا أسود ولا حتى ضباع .. ممكن أعدل تعديل بسيط على ملفك بحيث يكون مرن خلي المعادلة بهذا الشكل في الخلية F2 =IFERROR(VLOOKUP(COLUMN()-5,$A$2:$C$30,3,FALSE),"") واسحبها عبر الصفوف لأي عدد بدون تغيير المعادلة في كل مرة مشكور على إثرائك للموضوع تقبل تحياتي

بارك الله فيك أخي الحبيب ياسر فتحي جزيت خير الجزاء

أخي الكريم المنار إليك الكود التالي عله يفي بالغرض Sub LoopThroughAllWorkbooks() Dim FolderPath As String, FileName As String, strWBName As String Dim WBK As Workbook Dim SH As Worksheet Dim X As Long, Cell As Range FolderPath = ThisWorkbook.Path & "\Files\" FileName = Dir(FolderPath & "*.xl*") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Do While FileName <> "" Set WBK = Workbooks.Open(FolderPath & FileName) strWBName = Left(WBK.Name, (InStrRev(WBK.Name, ".", -1, vbTextCompare) - 1)) For Each Cell In ThisWorkbook.Sheets("Sheet1").Range("A2:A6") If Cell.Value = strWBName And Cell.Offset(, 1) <> "" Then With WBK.Sheets("المعلومات الأساسية") Range("A6").Value = "تاريخ الاستقالة" Range("B6").Value = Cell.Offset(, 1) Range("B6").NumberFormat = "m/d/yyyy" End With Exit For End If Next Cell WBK.Close SaveChanges:=True FileName = Dir() Loop Range("A1").Select Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub ومعك الملف المرفق للتجربة ..تم وضع الملفات في مجلد باسم Files حتى يتم العمل على المصنفات داخل المجلد لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي تقبل تحياتي Loop Through Closed Workbooks YK.rar

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

جرب تغير هذا السطر If Target.Cells.CountLarge > 1 Then Exit Sub إلى السطر التالي If Target.Cells.Count > 1 Then Exit Sub

الأخ الكريم أهلا بك في المنتدى ومرحباً بين إخوانك وأحبابك يرجى الإطلاع على رابط التوجيهات لمعرفة كيفية التعامل مع المنتدي كما يرجى تغيير اسم الظهور للغة العربية (دعوة للتمسك لغتنا الجميلة) إليك الملف المرفق لعله يكون المطلوب .. تم استخدام معادلات من النوع صفيف بالملف (أي أنه يجب الضغط على ثلاثة مفاتيح في وقت واحد عند إدخال المعادلة ألا وهم Ctrl + Shift + Enter المعادلة الأولى في الخلية D2 وهي لاستخراج القيم الفريدة اي الغير مكررة لأرقام الموظفين =IFERROR(INDEX($A$2:$A$30,MATCH(0,COUNTIF($D$1:D1,$A$2:$A$30&""),0)),"") ويتم سحبها نزولاً لأسفل المعادلة الثانية توضع في الخلية E2 =IFERROR(INDEX($B$2:$B$30, SMALL(IF($D2=$A$2:$A$30, ROW($A$2:$A$30)-ROW($A$2)+1),COLUMN()-4)),"") ويتم سحبها بشكل أفقي إلى أي عدد من الأعمدة تريدها ثم سحبها لأسفل :fff: لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي وأخيراً تقبل تحياتي وتوجيهاتي Unique Values & Multiple Corresponding VLOOKUP Values Across Rows YasserKhalil.rar