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

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

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