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

وجزيت خيراً أخي الكريم حمدي بمثل ما دعوت لنا وزيادة وبارك الله فيك على دعائك الطيب ، والحمد لله بقا فيه موضوع يتناول الترحيل الأفقي تقبل تحياتي

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

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله أحياناً تقابلنا في بعض المصنفات فلاشات تم إدراجها داخل الإكسيل .. ولذا فكرت في طريقة وبحثت كثيراً لكي أجد طريقة أستطيع بها استخراج الملف الفلاشي المدمج داخل المصنف ليكون الملف مستقل بذاته .. وذلك حتى أتمكن من إدراجه في مصنفات أخرى في الملف المرفق ستجد مصنفين أحدهما باسم Watch ويحتوي على الملف الفلاشي المدرج والمطلوب استخراجه ، والمصنف الثاني يحتوي على الكود الذي يؤدي المهمة بنجاح إن شاء الله تنفيذ الكود : عند تنفيذ الكود يظهر لك نافذة تحدد من خلالها مسار الملف الذي يحتوي الملف الفلاشي المدرج ، وهنا في المثال اسم الملف Watch ، والملف يحتوي على فلاش ساعة ...يمكن استخدامه في أي مصنف بعد استخراجه .. المهم حدد مسار الملف والكود سيقوم بالمهمة ويقوم باستخراج الملف الفلاشي .. ليكون الملف منفضل بذاته عن المصنف .. إليكم الكود المستخدم Sub ExtractFlash() Dim tmpFileName As String Dim FileNumber As Integer Dim myFileId As Long Dim MyFileLen As Long Dim myIndex As Long Dim swfFileLen As Long Dim I As Long Dim swfArr() As Byte Dim myArr() As Byte tmpFileName = Application.GetOpenFilename("MS Office File (*.doc;*.xls), *.doc;*.xls", , "Open MS Office file") If tmpFileName = "False" Then Exit Sub myFileId = FreeFile Open tmpFileName For Binary As #myFileId MyFileLen = LOF(myFileId) ReDim myArr(MyFileLen - 1) Get myFileId, , myArr() Close myFileId Application.ScreenUpdating = False I = 0 Do While I < MyFileLen If myArr(I) = &H46 Then If myArr(I + 1) = &H57 And myArr(I + 2) = &H53 Then swfFileLen = CLng(&H1000000) * myArr(I + 7) + CLng(&H10000) * myArr(I + 6) + CLng(&H100) * myArr(I + 5) + myArr(I + 4) ReDim swfArr(swfFileLen - 1) For myIndex = 0 To swfFileLen - 1 swfArr(myIndex) = myArr(I + myIndex) Next myIndex Exit Do Else I = I + 3 End If Else I = I + 1 End If Loop myFileId = FreeFile tmpFileName = Left(tmpFileName, Len(tmpFileName) - 4) & ".swf" Open tmpFileName For Binary As #myFileId Put #myFileId, , swfArr Close myFileId Application.ScreenUpdating = True MsgBox "Save The Extracted SWF Flash As [ " & tmpFileName & " ]" End Sub وأخيراً تقبلوا وافر تقديري واحترامي حمل الملف من هنا كان معكم أخوكم أبو البراء من منتدى أوفيسنا

أستودعك الله أخي الحبيب وائل سلام الله عليك ورحمت وبركاته نراك غداً إن شاء الله

أخي الحبيب وائل شعبان لا أدري بالضبط الشكل المطلوب والمسافات المطلوبة ولكن اعلم أن التعديل سهل للغاية .. والمسافات الموجودة متعمدة أي ستجد بعد الآيات وقبل اسم السورة 5 مسافات .. وفي غالب الأحيان مسافة واحدة .. لو لم تعرف كيفية ضبطها اذكر بمثال بالضبط المسافات المطلوبة وإن شاء الله الأمر يسير جداً بالنسبة للطلب الثاني أنصحك بالإطلاع على الموضوع التالي فيه الرد على سؤالك بالتفصيل .. وهي بدايات التعامل مع محرر الأكواد رابط الموضوع من هنا لو أحببت التعديل بنفسك في الكود ابحث عن هذا السطر ففيه سيكون التعديل Arr(I, 8) = "(" & Arr(I, 8) & " ) < " & Coll(CStr(Arr(I, 6))) & Space$(1) & Arr(I, 7) & " >" لاحظ الخمس مسافات التي تحدثت عنها .. يمكنك ضبط المسافات من هنا حسبما تريد جرب التعديل في هذه الأسطر (استبدال الأسطر الجديدة بالأسطر القديمة) On Error Resume Next For J = K1 To K2 Arr(I, 8) = Arr(I, 8) & " " & Coll(Arr(I, 6) & Chr$(2) & J) Next J Arr(I, 8) = "(" & Arr(I, 8) & ") < " & Coll(CStr(Arr(I, 6))) & " " & Arr(I, 7) & " >" On Error GoTo 0 تقبل تحياتي

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

وعليكم السلام ورحمة الله وبركاته أخي وحبيبي ومعلمي وأستاذي عبد الله المجرب لكم اشتقنا لتواجدك فيما بيننا ، عوداً حميداً .. ونرجو منك التواصل معنا ولو 5 دقايق كل يوم أشعرنا بوجودك فقط .. تقبل وافر تقديري واحترامي وحبي وتحياتي

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

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

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

أخي الحبيب أبو عيد بارك الله فيك وجزاك الله خيراً على هذا الإبداع اللامنتهي .. معادلات رائعة .. وإن كان هناك استعانة بكثير من الأعمدة المساعدة ولكن حل رائع ومتقن جداً أخي الكريم وائل شعبان إثراءً للموضوع إليك نفس الملف في المشاركة الأخيرة الخاصة بأخونا أبو عيد بعد حذف الأعمدة المساعدة والمعادلات لأنها وإن كانت حلاً رائعاً إلا أنها تثقل التعامل مع الملف بشكل كبير جداً خصوصاً أن حجم البيانات كبير للغاية .. مما يجعل التعامل مع الملف ثقيل جداً .. فإليك حل بالأكواد .. تم تغيير امتداد الملف لتتمكن من تنفيذ الكود والاحتفاظ به كل ما عليك هو تحميل الملف من الرابط أسفل المشاركة .. تفتح الملف ثم تضغط Alt + F8 وتنفذ الكود الذي سيظهر لك باسم Test عن طريق اختيار الإجراء الفرعي المسمى Test ثم تنقر Run ويمكن تخصيص زر لتنفيذ الأمر .. هذا هو الكود Sub Test() Dim Coll As New Collection, Arr, I As Long, J As Long, K1 As Long, K2 As Long, V Arr = Sheets("القرآن كاملا").Range("A1").CurrentRegion.Value For I = 2 To UBound(Arr, 1) Coll.Add Key:=Arr(I, 2) & Chr$(2) & Arr(I, 3), Item:=Arr(I, 4) Next I Arr = Sheets("القرآن كاملا").Range("F1").CurrentRegion.Value For I = 2 To UBound(Arr, 1) Coll.Add Key:=CStr(Arr(I, 1)), Item:=Arr(I, 2) Next I With Sheets("المثال").Range("F1").CurrentRegion Arr = .Value For I = 2 To UBound(Arr, 1) Arr(I, 8) = "" V = Split(Arr(I, 7), "|"): K1 = CLng(V(0)): If UBound(V) = 0 Then K2 = K1 Else K2 = V(1) On Error Resume Next For J = K1 To K2 Arr(I, 8) = Arr(I, 8) & Space$(1) & Coll(Arr(I, 6) & Chr$(2) & J) Next J Arr(I, 8) = "(" & Arr(I, 8) & " ) < " & Coll(CStr(Arr(I, 6))) & Space$(1) & Arr(I, 7) & " >" On Error GoTo 0 Next I .Value = Arr End With End Sub حمل الملف من هنا تقبل تحياتي

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

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

أخي الكريم راجع المعادلات وشوف رقم آخر صف مذكور في المعادلة يعني على سبيل المثال في ورقة العمل المسماة "جدول تحليل" في الخلية C4 يوجد رقم الصف في 523 ، وإذا نظرت في الورقة 1 ستجد أن رقم آخر صف هو 943 ... أعتقد أن هذه المشكلة لديك .. لا تنسى بعد التعديل في المعادلة السابقة أن تضغط Ctrl + Shift + Enter لأنها معادلة صفيف أما بقية المعادلات في ورقة العمل "جدول تحليل" ليست بصفيف ..

بارك الله فيك أخي الحبيب عبد الله فاروق وجزيت خيراً على نشاطك الممتاز بالمنتدى واصل بلا فوااااااااصل تقبل وافر تقديري واحترامي

أخي الكريم أخونا في الله (ولازم تقول اسمك .. إن شاء الله) بالنسبة لاستخدام الحلقات التكرارية جميل ومفيد ولكن مع البياناات الكثيرة يكون مريع ومخيف ويستغرق وقت طويل .. جرب في الملف المرفق بعد تغيير أسماء أوراق العمل .. ورقة العمل الأولى إلى Data وورقة4 إلى Result .. وزود البياناات إلى 10.000 صف مثلاً وجرب الكود الجميل الذي تفضلت به وجرب الكود التالي .. ولاحظ الفرق في التوقيت بالنسبة للتنفيذ Sub Unique_Count_Sum() Dim Ws As Worksheet, Sh As Worksheet Dim Rng As Range, Cel As Range Dim LR As Long Dim Dic, a Set Ws = Sheets("Data"): Set Sh = Sheets("Result") LR = Ws.Cells(Rows.Count, "E").End(xlUp).Row Set Rng = Ws.Range("E2:E" & LR) Set Dic = CreateObject("Scripting.Dictionary") With Sh.Range("B9").CurrentRegion .ClearContents: .Borders.Value = 0 End With On Error Resume Next For Each Cel In Rng If Cel <> 0 Then Dic.Add CStr(Cel), CStr(Cel) Next Cel a = Dic.Items Sh.Range("B9").Resize(Dic.Count) = Application.Transpose(a) With Sh.Range("C9").Resize(Dic.Count) .Formula = "=COUNTIF(Data!$E$2:$E$" & LR & ",B9)" .Offset(, 1).Formula = "=SUMIF(Data!$E$2:$E$" & LR & ",B9,Data!$F$2:$F$" & LR & ")" .Resize(, 2).Value = .Resize(, 2).Value End With Sh.Range("B9").CurrentRegion.Borders.Value = 1 End Sub أعتذر عن تغيير أسماء أوراق العمل ..حيث يكون التعامل باللغتين معاً في كتابة الكود أصعب ، وأنا أبحث عن الأيسر لي دائماً .. وهذا ليس تقليلاً للغة العربية أبداً .. * جزيت خيراً على الأسطر التي استفدت منها بخصوص عمل حدود للنطاق المستخدم ، استخدام بسيط ورائع تقبل تحياتي

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

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

جميل أخي الحبيب عبد الله بارك الله فيك وجزاك الله خيراً على هذه المعلومة القيمة

أخي الكريم علي المصري ... الخطأ الموجود في المرفق ليس سببه لا معادلات في ورقة العمل حيث لا توجد معادلات من الأصل في ورقة العمل ، ولا من النطاقات المسماة فقد قمت بمراجعتها ووجدت أنه ليس بها خطأ .. الخطأ سببه الـرسم البياني لديك .. عند فتح ملفك ومحاولة الحفظ تظهر الرسالة وعند تنفيذ الكود تظهر الرسالة ... وعندما حذفت الرسم البياني قام الملف بالحفظ واختفت الرسالة .. لا أدري ما الخلل في الرسم البياني ..عموماً جرب تحذف الرسم البياني ثم قم بإدراجه مرة أخرى .. تقبل تحياتي

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

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

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

وعليكم السلام أخي الحبيب محي الدين الحمد لله أن انتبهت للخطأ الموجود ..أما بخصوص الزهايمر فالحال من بعضه ، وكلنا هذا الرجل وجزيت خيراً بمثل ما دعوت لي ، وتأكد أنني أستمتع بالتفاعل المثمر الذي يعلمني قبل أن يعلم غيري تقبل تحياتي

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