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

الأخ إبراهيم مشكور على مرورك العطر والحمد لله أنك تستفيد من موضوعاتي الأخ الكبير مختار المتمكن تسلم على مرورك العطر .. وفي انتظار إبداعاتك ..

تم تحرير المشاركة الأولى أخي مختار مرة أخرى ..حمل النسخة الثانية من الملف .. وفي انتظار ملاحظاتكم للوصول لأفضل أداء للكود ... وفي انتظار إضافاتك يا مختار يا متمكن

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

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

الأخ الحبيب عاشق الإسلام بارك الله فيك وجزيت خيراً على دعائك الطيب الأخ الغالي حسام ميلكانا مشكور على مرورك العطر وكلماتك الرقيقة ..تسلم يا أخ حسام الأخ ناصر سعيد أنا بسمع الفيديو والصوت واضح عندي ..وصدقني أنا بقدر الإمكان أثناء تسجيل الفيديو بعلي صوتي .. ويا ريت الاخوة اللي بيشوفوا الفيديوهات يقيموا الفيديو ..هل الفيديو واضح أم لا والصوت واضح أم لا ... أخي ناصر جرب في الفيديو على اليوتيوب فيه علامة ترس أسفل يمين الفيديو خلي الـجودة Quality 720 HD وشوف أداء الفيديو .. الأخ الحبيب والأستاذ الكبير إبراهيم أبو ليلة مشكور على مرورك العطر .. وها هو رابط الموضوع الآخر .. http://www.officena.net/ib/index.php?showtopic=60289 تقبلوا تحياتي

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

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله أقدم لكم كود متميز جداً .. كود في منتهى الروعة .. إن شاء الله تستفيدوا منه أقصى استفادة .. الكثير منا يبحث عن موضوع فصل الناجحين والراسبين .. ها أنا أقدم لك على طبق من كود : الكود الذهبي الذي سيقوم بذلك بمنتهى السهولة واليسر .. هذا هو الشكل العام للكود Sub SplitFilteredData() 'الإعلان عن المتغيرات Dim MySheet As Worksheet Dim MyRange As Range Dim UList As Collection Dim UListValue As Variant Dim I As Long 'تخصيص ورقة العمل النشطة Set MySheet = ActiveSheet 'إذا لم تحتوي ورقة العمل على فلترة يتم الخروج من الإجراء الفرعي If MySheet.AutoFilterMode = False Then Exit Sub End If 'حدد العمود الذي يحتوي على البيانات المراد عمل تصفية لها Set MyRange = Range(MySheet.AutoFilter.Range.Columns(5).Address) 'إنشاء كائن تجميعي Set UList = New Collection 'وضع قيم في الكائن التجميعي بالقيم الفريدة أي الغير مكررة فقط On Error Resume Next For I = 2 To MyRange.Rows.Count UList.Add MyRange.Cells(I, 1), CStr(MyRange.Cells(I, 1)) Next I On Error GoTo 0 'حلقة تكرارية للقيم الموجودة داخل الكائن التجميعي For Each UListValue In UList 'حذف أية أوراق عمل تم إنشاءها من قبل On Error Resume Next Application.DisplayAlerts = False Sheets(CStr(UListValue)).Delete Application.DisplayAlerts = True On Error GoTo 0 'عمل تصفية لمطابقة القيمة الحالية MyRange.AutoFilter Field:=5, Criteria1:=UListValue 'نسخ النطاق الذي تم تصفيته إلى ورقة عمل جديدة MySheet.AutoFilter.Range.Copy Worksheets.Add.Paste ActiveSheet.Name = Left(UListValue, 30) Cells.EntireColumn.AutoFit 'إعادة الحلقة التكرارية مع قيمة أخرى Next UListValue 'الذهاب للصفحة التي تحتوي على البيانات وإزالة الفلترة MySheet.AutoFilter.ShowAllData MySheet.Select End Sub في الفيديو شرح لكيفية استخدام الكود .. ومرفق في الموضوع الملف الذي تم الشرح عليه إليكم رابط الفيديو لا تنسونا من صالح دعائكم ، ولا تنسوا اللايكات في اليوتيوب ... تقبلوا تحيات أخوكم أبو البراء Split Filtered Data VBA.rar Split Filtered Data VBA V2.rar

إذا كان هذا هو الكود جرب التعديل بهذا الشكل Sub Tarhilممم() Dim WS As Worksheet, SH As Worksheet Dim LRWS As Long, LRSH As Long Dim X As Long, I As Long Set WS = Sheets("bon de livraison "): Set SH = Sheets("اليوميات") LRWS = WS.Cells(50, 1).End(xlUp).Row X = Application.WorksheetFunction.CountA(WS.Range("A20:A" & LRWS)) Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False For I = 1 To X LRSH = SH.Cells(Rows.Count, 4).End(xlUp).Row + 1 'ترحيل التاريخ SH.Cells(LRSH, 4).Value = WS.Range("B17") SH.Cells(LRSH, 3).Value = WS.Range("F13") 'ترحيل الاسم SH.Cells(LRSH, 5).Value = WS.Range("B11") 'ترحيل البيان SH.Cells(LRSH, 6).Value = WS.Cells(19 + I, 2).Value 'ترحيل الكمية SH.Cells(LRSH, 7).Value = WS.Cells(19 + I, 1).Value 'ترحيل السعر SH.Cells(LRSH, 8).Value = WS.Cells(19 + I, 3).Value 'ترحيل الإجمالي SH.Cells(LRSH, 9).Value = WS.Cells(19 + I, 6).Value Next I MsgBox "تم الترحيل بحمد الله", vbInformation, "YasserKhalil" Application.EnableEvents = True Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub سيتم حل مشكلتك بإذن الله

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

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

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

والأروع مرورك العطر أ/حكيم ..تقبل تحياتي

اطلعت على الملفين أخي الفاضل ولم أفهم المطلوب .. هل المطلوب مرتبط بالملفين معاً ..وأين شيت المدة الذي تتحدث عنه!!!!!!!!

الأستاذ حكيم الأخ الفاضل عمار بارك الله فيكما وجزاكما الله خير الجزاء ..تقبلا تحياتي

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

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

سلمت من كل سوء ومن كل شر يا باشمهندس .. بارك الله فيك وجزاك الله كل خير

السلام عليكم ورحمة الله وبركاته إخواني الأحباب سبق أن قمنا بكسر حماية محرر الأكواد بدون برامج .. الآن مع كسر حماية أوراق العمل بالاستعانة ببرنامج صغير الحجم اسمه XML Marker وهو برنامج للتعديل على ملفات الـ XML وهو مرفق في الموضوع ... أترككم مع الفيديو ..عسى أن تستفيدوا منه إن شاء الله (ومتنسوش اللايكات !!) تقبلوا تحيات أخوكم أبو البراء xmlmarker_2_2_setup.rar

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

أخي الغالي ياسر فتحي كله بفضل الله ثم بفضل دعائكم لي ..بارك الله فيكم وجزيتم خير الجزاء ..ومتنساش اللايك !!!!!

أخي الفاضل مشكور على دعائك الطيب وعلى إطرائك الجميل وعلى مرورك العطر تقبل تحياتي

ارفق ملفك أخي الحبيب للإطلاع عليه

أخي الحبيب إكرامي رمضان مشكور على مرورك العطر وعلى أول لايك ..بارك الله فيك

السلام عليكم ورحمة الله وبركاته إخواني الكرام .. قد يكون موضوع الكسر موضوع شائك وفيه خلاف ، ولكن ربما يكون مفيد لصاحب العمل نفسه ، حيث أنه معرض لنسيان الباسورد الذي تم وضعه على محرر الأكواد .. الموضوع مميز لأنه يقوم بكسر الحماية بدون برامج على الإطلاق ..وبدون AddIns وبدون الاستعانة بأية برامج مجانية أو مدفوعة !! كسر محرر الأكواد بالأكواد نفسها (قنبلة الموسم) وعلى رأي المثل : علمته رمي السهام فلما اشتد ساعده رماني .. الكود قليل الأصل !! محفظش الجميل للبيئة اللي هو منها ، لأنه كسر بيئة محرر الأكواد !!! Sub HackVBA() Open "C:\Users\Future\Desktop\Test.xls" For Binary As #1 Put #1, 1, Replace(Input(LOF(1), 1), "DPB=", "DPX=", , 1) Close Workbooks.Open "C:\Users\Future\Desktop\Test.xls" End Sub المطلوب فقط أن تغير مسار الملف المراد كسره داخل الكود ، والمسار يوضع بين أقواس تنصيص .. أترككم مع الفيديو عله ينال إعجابكم وتستفيدوا منه إن شاء المولى .. ولا تنسونا من اللايكات على اليوتيوب !!!!! ....أكرر اللايكات على اليوتيوب ..فضلاً لا أمراً تقبلوا تحيات أخوكم أبو البراء

الأخ الحبيب سعيد جرب الكود بهذا الشكل .. Sub Copeir_Tebel() 'لنسخ الجدول ايضا بنفس ارتفاع الصفوف Dim sh As Worksheet: Set sh = Sheets("data") Dim sh2 As Worksheet: Set sh2 = Sheets("مكافاة الثانوية العامة") Dim lr As Long: lr = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row + 2 Dim i As Integer Dim Rw1 As Long, Rw2 As Long, Rw3 As Long Rw1 = lr + 4 sh2.Rows(lr - 2 & ":" & lr - 2).Copy sh2.Range("A" & Rw1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False sh2.Rows("8:28").Copy sh2.Range("A" & lr + 5).Select ActiveSheet.Paste Application.CutCopyMode = False Dim Lrw As Long: Lrw = sh2.Cells(sh2.Rows.Count, 2).End(xlUp).Row Dim x As Integer: x = sh2.Range("A" & lr - 3) + 1 For i = lr + 5 To Lrw sh2.Range("A" & i) = x x = x + 1 Next Rw2 = Lrw: Rw3 = Lrw + 1 sh2.Cells(Rw3, 14).Formula = "=IF(SUM(N" & Rw1 & ":N" & Rw2 & ")=0,"""",SUM(N" & Rw1 & ":N" & Rw2 & "))" sh2.Cells(Rw3, 14).Select Selection.AutoFill Destination:=Range("N" & Rw3 & ":W" & Rw3), Type:=xlFillDefault sh2.Range("N" & Rw3 & ":W" & Rw3).Select Dim MyString As String, sXXXX As String Dim lID As Long MyString = sh2.Range("A" & lr - 2) lID = Mid(MyString, 12, Len(MyString)) sXXXX = Mid(MyString, 1, 11) sh2.Range("A" & lr + 4) = "ماقبله جملة كشف " & lID sh2.Range("A" & Lrw + 1) = sXXXX & lID + 1 ActiveSheet.PageSetup.PrintArea = "$A$1:$X" & Lrw Dim Str As Byte: Str = 34 FinalRow = Range("A65536").End(xlUp).Row For i = Str To FinalRow Step 27 ActiveSheet.Cells(i, 1).Select ActiveSheet.HPageBreaks.Add before:=Cells(i, 1) Next i End Sub وشوف النتائج صحيحة كما تتوقعها .. تقبل تحياتي