احمد بن ابراهيم

الف شكر لك استاذ عبدالله وربي يسعدك الملف يعمل بشكل رائع . تكرما لو كان الجدول يحتوي على جداول في الصفوف العليا وارغب بتقسيم جدول البيانات ويكون كل جدول يحتوي على البيانات والجداول كما في ورقة العمل الاصلية . الشرقية1 (2).xlsm

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

السلام عليكم ورحمة الله وبركاته زملائي المبدعين اليوم احببت ان اطلب من Chat GPT عمل كود VBA يعمل على تقسيم بيانات ورقة عمل حسب اختياري للعامود على شكل اوراق عمل ( SHEET) منفصلة باسم البيان ثم يفصل كل ورقة عمل اكسل داخل مجلد باسم البيان . واظهر لي هذا الكود . بس فيها مشكلة تحتاج الى حل (مرفق ملف العمل). ولكم جزيل الشكر Sub SplitDataBySelectedColumn() Dim wsSource As Worksheet Dim wsNew As Worksheet Dim rng As Range Dim cell As Range Dim dict As Object Dim key As Variant Dim lastRow As Long Dim header As Range Dim colToSplit As String Dim colLetter As String Dim colNum As Long ' طلب العمود من المستخدم colToSplit = InputBox("أدخل حرف العمود الذي تريد الفصل بناءً عليه (مثل D):", "اختيار العمود") If colToSplit = "" Then MsgBox "تم الإلغاء.", vbExclamation Exit Sub End If colToSplit = UCase(colToSplit) ' تحديد ورقة العمل الحالية كمصدر Set wsSource = ActiveSheet ' تحديد آخر صف في العمود المحدد lastRow = wsSource.Cells(wsSource.Rows.Count, colToSplit).End(xlUp).Row ' تحديد نطاق البيانات Set header = wsSource.Rows(1) Set rng = wsSource.Range("A2:" & wsSource.Cells(lastRow, wsSource.Columns.Count).End(xlToLeft).Address) ' إنشاء قاموس للقيم الفريدة Set dict = CreateObject("Scripting.Dictionary") ' جمع القيم الفريدة من العمود المحدد For Each cell In wsSource.Range(colToSplit & "2:" & colToSplit & lastRow) If Not dict.exists(cell.Value) And Trim(cell.Value) <> "" Then dict.Add cell.Value, Nothing End If Next cell Application.ScreenUpdating = False ' إنشاء شيت لكل قيمة فريدة For Each key In dict.keys ' التحقق من وجود الشيت مسبقًا Set wsNew = Nothing On Error Resume Next Set wsNew = ThisWorkbook.Sheets(CStr(key)) On Error GoTo 0 If wsNew Is Nothing Then Set wsNew = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)) wsNew.Name = Left(CStr(key), 31) ' الحد الأقصى لاسم الشيت 31 حرف End If wsNew.Cells.Clear ' نسخ العناوين header.Copy Destination:=wsNew.Range("A1") ' تصفية البيانات حسب القيمة الحالية wsSource.Rows(1).AutoFilter Field:=wsSource.Range(colToSplit & "1").Column, Criteria1:=key wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=wsNew.Range("A2") Next key ' إلغاء التصفية wsSource.AutoFilterMode = False Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "? تم إنشاء الشيتات بنجاح بحسب العمود " & colToSplit, vbInformation End Sub الشرقية.xlsm

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

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

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

بارك الله فيكم اجمعين رائع تستاهلون

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

الحمد الله تمت المهمة لكم جزيل الشكر ابو البراء

مبروووك استاذ سليم اهل الخير يستاهلون الخير نفع الله بعلمك واعانك الله على كل من يحبونك

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

اسعد الله ايامكم الكود المطلوب التعديل علية تعلمته من الاستاذ صاحب قناة اليوتيوب ( تعلم الاكسل معي ) جزاه الله خير وهو يعمل على ( حماية او فتح الحماية لجميع الشيتات عن طريق اختصارات ) المطلوب : اضافة لو تكرمتم على كود الحماية لجميع الشيتات Sub protectclose() Dim a As Worksheet For Each a In Worksheets If a.ProtectScenarios = False Then a.protect "1111" End If Next a End Sub بمنع حماية بعض الشيتات المختارة ويحمي بقية الشيتات ولكم جزيل الشكر الغاء الحماية لبعض الاوراق.rar

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

استاذ عمر ممكن التشرف بالتواصل معكم على الإيميل abdhhh2009@gmail.com لاخذ اقتراحاتك و ملاحظاتك للاهمية

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

استاذ عمر ممكن اضافة هل ممكن في الاكسل عمل ايقونة لإظهار الشرح ( كما شرحت على الملف ) و عند الضغط علية مرة ثانية تختفي الشروحات وشكرا

الف الف الف شكر لك اخي العزيز عمر اتممت المهمة بحمد الله بشكل جميل ( اتعبتك في صياعة الاكواد ) و تم اعتماد هذا العمل اسعدك الله في الدارين واشكرك على حسن متابعتك معي

تسلم اخي سليم اضافة جميلة منك والناتج منها ممتاز ( احببت تعلمها منك ) بنسبة للعامود D و E هم كذالك بيانات مكررة لم تتغير اسعد الله ايامك استاذ سايم

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

السلام عليكم بنسبة لي فكنت ارغب بعملية فلترة على نفس الجدول ( مثل الفلترة العادية ) يكون البحث بالاسم في خلية B9 اذا كنت ارغب بالبحث عن اسم معلم يتقلص فية الجدول الى اسم المعلم مع ثلاثة الصفوف الخاصة به لجميع الاعمدة او يمكن البحث حسب المرحلة الدراسية في خلية E9 ب = ابتدائي م = متوسط ث = ثانوي فيخرج معي اسماء المعلمين لهاذة المرحلة استاذ عمر لقد قمت بتعديل و ازالة الدمج شاهد المرفق ahmed 2.rar

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

بارك الله فيك استاذي / سليم حاصبيا و لا حرمنا الله من التعلم منكم و حسن تواصلكم لك جزيل الشكر و كما قلت ( الخلايا المدمجة من الد اعداء الكود والمعادلة )

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

تسلم ابو أدهم الله يريح بالك . تجميعة متميزة بارك الله في جهودكم

لك جزيل الشكر ابوحنف على حسن تواصلك و شرحك المتميز عى الكود حيث ان الكود طويل و انا استخدم كود مختصر ( جزا الله خير من قام بعمله ) lr = Range("b" & Rows.Count).End(xlUp).Row ActiveSheet.Range("$B$4:$C$" & lr).AutoFilter Field:=1, Criteria1:="=" & ActiveSheet.TextBox1.Text & "*" وطريقة تكرار الاسماء معلومة لدي ولكن مع كثرة الاسماء تفوق 70 اسم يصبح الجدول غير منظم و مزعج . و علمت ان التصفية لا يمكن عملها في وجود صفوف مدمجة ولاكن احببت طرح الموضوع في هذا المنتدى لما يتمتع به من وجود اعضاء متميزين و رحابة الصدر في حواراتهم . لعلي اجد من الهمة الله بالعلم فيجد حلول لها . فبرنامج الإكسل عبارة عن لعبة الغاز نحاول حل مفرداتها. فبارك الله في جهود الجميع .