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

وعليكم السلام أخي العزيز أبو عيد إذا كنت تقصد شكل الرقم (الأرقام الهندية) فهذا يتم التحكم فيه من خلال لوحة التحكم Control Panel كما بالصورة التالية

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

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

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

وعليكم السلام جرب الملف التالي عله يفي بالغرض إن شاء الله KMSAuto Net 2015 v1.3.6.rar

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

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

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

صحيح يا أبو العربي أجمل الحلول أبسطها بارك الله فيك ووفقك الله لما يحب ويرضى

دائماً ما تتحفنا بموضوعاتك القيمة والرائعة والمدهشة بارك الله فيك وجزيت خيراً أخانا الغالي أبو صهيب

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

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

حاولت أن أقوم بتشغيل الملف والحمد لله توصلت للحل وأقدم الحل عسى أن يكون مفيد لكم إن شاء الله قم بفك الضغط عن الملف المرفق في المشاركة الأولى ثم اتبع التالي .. بعد الدخول على محرر الأكواد عن طريق Alt + F11 قم بالدخول على القائمة Tools ثم References ستظهر لك نافذة بها خيارات وستجد بعض الخيارات في أولها كلمة Missing أي أنها مكتبة مفقودة قم بإزالة علامات الصح من جانب هذه الخيارات فقط .. من نافذة المشروع اعمل كليك يمين ثم اختر الأمر Insert ثم UserForm لإدراج فورم جديد من صندوق الأدوات Control Box اعمل كليك يمين في مكان فارغ ثم اختر الأمر Additional Controls ابحث عن الخيار Microsoft ListView Control وعلم في المربع بجواره ليتم إدراجه في صندوق الأدوات الآن قم برسم الأداة على الفورم الجديد ثم احفظ المصنف من علامة الحفظ وأخيراً بعد الحفظ قم بحذف الفورم الذي تم إدراجه ، ستظهر لك رسالة اختر منها No الآن قم بتشغيل الفورم الأساسي في الملف ستجد أنه يعمل إن شاء الله تقبلوا وافر تقديري واحترامي

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

أخي الحبيب سليم بارك الله فيك وجزيت خيراً على أعمالك الممتازة إثراءً للموضوع .. إليك الكود التالي (قم بتنسيق الخلايا التي ستظهر فيها النتائج كنص) Sub Test() Dim Coll As New Collection, arr, maxItem As Long, I As Long, J As Long, str1 As String, V1, V2 arr = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value For I = 1 To UBound(arr, 1) str1 = CStr(arr(I, 1)) On Error Resume Next Coll.Add Key:=str1, Item:=New Collection On Error GoTo 0 If Coll(str1).Count = 0 Then Coll(str1).Add str1 For J = 2 To UBound(arr, 2) If Len(arr(I, J)) Then Coll(str1).Add arr(I, J) Next J Next I For Each V1 In Coll If V1.Count > maxItem Then maxItem = V1.Count Next V1 ReDim arr(1 To Coll.Count, 1 To maxItem) I = 0 For Each V1 In Coll I = I + 1 J = 0 For Each V2 In V1 J = J + 1 arr(I, J) = V2 Next V2 Next V1 For J = 2 To maxItem arr(1, J) = J - 1 Next J Range("F1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr End Sub تقبل تحياتي

أخي الكريم بوكر ليبيا قم بالإطلاع على الملف التالي للأخ يحيى حسين فيه شرح للدالة INDEX علها تعينك على فهم المعادلة في ملفك .. INDEX Function.rar

بارك الله فيك أخي العزيز أبو صهيب فكرة بسيطة ورائعة ، وموضوع رائع جزيت خير الجزاء .. واصل بلا فواصل فما زال هناك الكثير في جعبتك

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

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

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

بارك الله فيك أخي العزيز عامر وجزيت خيراً واصل بلا فواصل ..

أخي الكريم حاتم عيسى يرجى دائماً إرفاق ملف للعمل عليه وتيسير تقديم المساعدة المطلوبة عموماً جرب التعديل التالي عله يفي بالغرض Sub Transfer_Data() Dim Sh_Master As Worksheet Dim Rng As Range Dim Arr() Application.ScreenUpdating = False Set Sh_Master = Sheets("الرئيسية") For Each sh In Sheets If sh.Name <> Sh_Master.Name Then sh.Unprotect 123 sh.Range("B7:H" & Rows.Count).ClearContents End If Next sh End_Row = Sh_Master.Cells(Rows.Count, "C").End(xlUp).Row Set Rng = Sh_Master.Range("A6:N" & End_Row) Arr = Rng For Row = 2 To UBound(Arr) For Col = 7 To 12 If Arr(Row, Col) = 1 Then ShName = Arr(1, Col) End_Row = Sheets(ShName).Cells(Rows.Count, "C").End(xlUp).Row + 1 Set Rng = Range(Sh_Master.Cells(Row + 5, "B"), Sh_Master.Cells(Row + 5, "F")) Rng.Copy Sheets(ShName).Range("B" & End_Row) Sheets(ShName).Range("G" & End_Row) = Arr(1, Col) '============================== Sheets(ShName).Range("H" & End_Row) = Sh_Master.Cells(Row + 5, "N") - 1 ' OR ' Sheets(ShName).Range("H" & End_Row) = "عنده مواد تالية" '============================== End If Next Col Next Row For Each sh In Sheets If sh.Name <> Sh_Master.Name Then sh.Protect 123 End If Next sh Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub تقبل تحياتي

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

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

ارفق الملف الذي تعمل عليه ..لربما يوجد خلايا مدمجة أو خلافه