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

أخي الكريم أيمن ورقة10 هي ورقة العمل المدارس (وورقة10 هو الاسم البرمجي لها المستخدم في محرر الأكواد) يمكنك الإطلاع على الأسماء البرمجية لأوراق العمل من خلال نافذة المشروع

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

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

أخي الكريم يرجى وضع الأكواد بين أقواس الكود كما يرجى إرفاق ملفك لتتضح الصورة ويتضح المطلوب تقبل تحياتي

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

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

أخي الكريم عبد العزيز جرب الكود التالي في وجود الدالة المعرفة ... Sub TestRun() Dim I As Integer For I = 2 To Cells(Rows.Count, "B").End(xlUp).Row If Kh_Names(Cells(I, "B"), 1) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) ElseIf Kh_Names(Cells(I, "B"), 1, 2) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) Cells(I, "G") = Kh_Names(Cells(I, "B"), 2) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) Cells(I, "D") = Kh_Names(Cells(I, "B"), 2) Cells(I, "G") = Kh_Names(Cells(I, "B"), 3) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) Cells(I, "D") = Kh_Names(Cells(I, "B"), 2) Cells(I, "E") = Kh_Names(Cells(I, "B"), 3) Cells(I, "G") = Kh_Names(Cells(I, "B"), 4) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4, 5) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) Cells(I, "D") = Kh_Names(Cells(I, "B"), 2) Cells(I, "E") = Kh_Names(Cells(I, "B"), 3) Cells(I, "F") = Kh_Names(Cells(I, "B"), 4) Cells(I, "G") = Kh_Names(Cells(I, "B"), 5) End If Next I End Sub وهذا سيستلزم أن تقوم بالنقر على زر الأمر لكي يقوم الكود باختبار كل اسم على حدا .. حسب ما سترى في الملف المرفق أرجو أن يفي بالغرض Split Compound Names UDF Function V2.rar

أخي الغالي جعفر جربت الملف ولم تعمل الفلترة عند كتابة السعر في الخلية A3 .. أنا أعمل على ويندوز 10 64 بت والأوفيس 2013 64 بت تقبل تحياتي

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

حاجة من 4 احتمالات يا كبير يا إما إنت أرفقت ملف آخر غير ملفك الأصلي .. يا إما يكون مفتاح F12 عندك معلق من لوحة المفاتيح ..يا إما ميكونش فيه طابعة منصبة في جهازك وبيطالب الكود بحفظ الملف بامتداد PDF .. أو تكون الطابعة المنصبة هي الطابعة الغير افتراضية ..! ارفق ملفك الأصلي للإطلاع عليه أخي الفاضل

أخي الكريم عبد العزيز إليك دالة معرفة تقوم بالأمر ونسبة نجاحها حوالي 95% .. الأمر لن يسلم من بعض الأخطاء البسيطة ... توضع الدالة المعرفة في موديول جديد .. Function Kh_Names(FullName As String, ParamArray Index1()) As String Dim I As Integer Dim Kh_Split, MyArray, Arr Dim Kh_String As String, SN As String, RE As String On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", "زين ") SN = Application.WorksheetFunction.Trim(FullName) For Each Arr In MyArray RE = Replace(Arr, " ", "^") SN = Replace(SN, Arr, RE) Next Kh_Split = Split(SN, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(Index1) Kh_String = Kh_String & " " & Kh_Split(Index1(I) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") Kh_Names = Kh_String Exit Function Err_Kh_Names: Kh_Names = "" End Function وإليك الملف المرفق فيه توضيح لكيفية استخدام الدالة أرجو أن تفي بالغرض تقبل تحياتي Split Compound Names UDF Function.rar

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

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

أخي الكريم صلاح أعتذر بشكل مبدئي حيث أنني قمت بتنسيق المصنف المرفق بما أحب أن أره منسقاً (مرض نفسي بعيد عنك) ..معرفش أشتغل على ملف غير لما أنسقه بأسلوبي الأول .. لكن تبقى هيكلة الملف كما هي لا تقلق جرب الكود التالي لعله يفي بالغرض .. ولكن لابد من تواجد أوراق العمل بشكل مسبق لكل لا يحدث خطأ في حالة عدم وجود ورقة العمل المراد الترحيل إليها Sub TransferByRegion() Dim Ws As Worksheet Dim Sh As Worksheet Dim Cel As Range Dim LR As Integer Dim Last As Integer Set Ws = Sheet1 Application.ScreenUpdating = False For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> "العملاء" Then With Sh.Range("A1:C" & Sh.Cells(Rows.Count, 1).End(xlUp).Row) .Offset(1).ClearContents .Borders.LineStyle = xlNone End With End If Next Sh With Ws LR = .Cells(Rows.Count, 1).End(xlUp).Row .Range("A1").CurrentRegion.Copy .Range("H1") Range("H1:J" & LR).Sort Key1:=Range("I1:I" & LR), Order1:=xlAscending, Key2:=Range("J1:J" & LR), Order2:=xlAscending, Header:=xlYes For Each Cel In Ws.Range("I2:I" & LR) Last = Sheets(Cel.Value).Cells(Rows.Count, 2).End(xlUp).Row + 3 Sheets(Cel.Value).Range("B" & Last).Resize(1, 2).Value = Cel.Resize(1, 2).Value Sheets(Cel.Value).Range("A" & Last).Value = Application.WorksheetFunction.CountA(Sheets(Cel.Value).Columns(2)) - 1 Next Cel .Columns("H:J").Delete End With For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> "العملاء" Then With Sh.Range("A1:C" & Sh.Cells(Rows.Count, 1).End(xlUp).Row) .Borders.Weight = xlThin .BorderAround Weight:=xlThin End With End If Next Sh MsgBox "Done. God Bless You Salah", 64 Application.ScreenUpdating = True End Sub تقبل تحياتي Transfer Data Based On Region & Insert Two Empty Rows YasserKhalil.rar

أخي الكريم صلاح ماذا تقصد بالترتيب الأبجدي ؟ هل الترتيب الأبجدي للأسماء التي يتم ترحيلها أم تقصد ترتيب أبجدي للمناطق التي سترحل؟ وأمر آخر : هل أوراق العمل التي سيتم الترحيل إليها موجودة أم أنك تطلب أن يتم إنشاء أوراق العمل ؟ نرجو الإيضاح ليستطيع إخوانك بالمنتدى تقديم المساعدة تقبل تحياتي

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

أخي الكريم أبو عبد الواحد .. ضع السطر التالي بعد سطر الطباعة الذي تفضل به الأخ الفاضل صلاح المصري ThisWorkbook.Save تقبل تحياتي

أخي الكريم جرب تنصب نسخة أوفيس تانية غير اللي موجودة عندك تقبل تحياتي

أخي الكريم حليم بسرعة عشان وقت صلاة الجمعة روح للتبويب Formulas ثم الـ Name Manager ثم انقر لكمة New واكتب اسم القائمة المطاطية اسم List مثلاً .. وضع المعادلة التالية =OFFSET(Feuil1!$C$8,0,0,COUNTA(Feuil1!$C:$C)-1,1) بعد كدا روح لورقة العمل المسماة Feuil2 وحدد الخلية C6 وروح للتبويب Data ثم Data Validation واختار List من القائمة وبعدين اكتب كلمة =List في المعادلة الخاصة بالقائمة .. بس خلاص وتقبل تحياتي

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

أخي الكريم رغم أنني لم أفهم المطلوب بشكل جيد لعدم التوضيح الجيد .. ولكن قم بهذه المحاولة وحرب السطر التالي لاستدعاء الكود المطلوب With Sheets("Sheet1").Range("A1") If .Value = "hide" Then B_Click: .Value = "" End With

أخي الكريم نور أفضل من كلمة شكراً كلمة "جزاكم الله خيراً" ..هذه الأخيرة محببة أكثر إلى قلوبنا تقبل تحياتي

أخي الكريم ابن الملك إليك الكود التالي لعله لا يكون المطلوب بشكل كامل كما أردت ولكن قد يكون مفتاح للحل ..حيث أن صفحات ورقة العمل الواحدة تختلف حسب إعدادات الطابعة المنصبة لديك .. ولو غيرت الطابعة ربما تختلف إعدادات الصفحة عموماً إليك الحل التالي يعتمد على النطاق المحدد ..أي قم بتحديد النطاق أولاً ثم تنفيذ الكود ليتم تصديره إلى مصنف جديد Sub Copy_Selected_Range_As_New_Workbook() Dim a As Range, rng As Range Application.ScreenUpdating = False Set rng = Selection ActiveSheet.Copy If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData Columns.Hidden = False Rows.Hidden = False Cells.ClearContents For Each a In rng.SpecialCells(xlCellTypeVisible).Areas Range(a.Address).Value = a.Value Next a ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\YourFileName.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ActiveWorkbook.Close Application.ScreenUpdating = True End Sub تقبل تحياتي Export Selected Range To New Workbook YasserKhalil.rar

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

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