نجوم المشاركات

استعمل هذا الكود Sub MyNmbr() Dim x As Integer, i As Integer x = 1 For i = 2 To Range("a1").Value * 3 Step 3 Cells(i, 3) = x x = x + 1 Next End Sub

ربما كان هذا المطلوب test2 salim.rar

ما شاء الله تبارك الله كفيتم ووفيتم كتب الله لكم الأجر وغفر لكم الذنب وأعانكم لكل خير عظيم الشكر وجزيل الامتنان لكم ..

السلام عليكم ورحمة الله وبركاته اكتب هذه المعادلة فى الخلية H3 =IF(OR($D3:$G3="ح");"ح";IF(OR($D3:$G3="غ");"غ";SUM($D3:$G3))) ثم اضغط على CRTL + ALT + SHIFT ثم اسحب نزولا

أخي الكريم سيد يرجى وضع عناوين مناسبة ومعبرة عن الطلب ..بارك الله فيك قم بالتالي : انسخ الكود لموديول جديد والصقه في الموديول .. في ورقة العمل المسماة "قوائم" وفي الخلية D1 ضع الصف المطلوب جلب القوائم له وليكن الرقم 1 للصف الأول في نفس ورقة العمل وفي الخلية المجاورة في الخلية E1 ضع الفصل المطلوب جلب القوائم له وليكن 1 أيضاً أي 1 / 1 ... ثم ارسم زر أمر واعمل كليك يمين عليه ثم Assign Macro واختر اسم الماكرو Test ليكون مرتبط بالتنفيذ .. انقر على زر الأمر لتنفيذ الكود ..وياريت تراجع النتائج بشكل جيد الكود من هنا تقبل تحياتي

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

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

شوف الرابط التالي لتعرف كيفية التحميل .. من هنا

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

يمكنك تجربة هذ الملف المصنف salim.rar

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

لتفعيل النسخ الإحتياطي التلقائي ، قم بما يلي: أولاً : إعدادت إختيار قواعد البيانات لعمل النسخ الإحتياطى التلقائي لها 1) انقر على الزر "إعداد النسخ الإحتياطي التقائي". أدخل المسار الكامل لقواعد البيانات التي ترغب في النسخ الاحتياطي لها.بإستخدام الزر "استعراض لإختيار قواعد البيانات" 2)انقر على الزر "إضافة قاعدة بيانات إلي القائمة" لإضافة قاعدة بيانات جديدة. 3) انقر مرتين على أي قاعدة بيانات في القائمة للتعديل أو الحذف. ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ ثانياً : إعدادات مسار تخزين النسخ الإحتياطى التلقائي حدد المسار الكامل الذي تريد حفظ قواعد بيانات النسخ الاحتياطي.فيه عن طريق النقر على الزر "تحديد مسار التخزين" وهذا المسار يجب بالفعل أن يكون موجوداً أو سوف يتم إحباط العملية. ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ ثالثاً : إعدادات وقت النسخ الإحتياطي التلقائي تحديد وقت بدء النسخ الإحتياطي التلقائي هام جداً جداً جداً أدخل الوقت بهذا التنسيق (HH:MM:SS AM / PM) شرح التسيق HH الساعة MM الدقيقة SS الثانية AM / PM أو ص / م وهذا يشير لتحديد الساعة صباحا او مساءً ويظهر هذا التنسيق فقط عندما تكون إعدادت نظام التشغيل تم تحديد الوقت فيه على نظام 12 ساعة مثال عندما نريد نسخ تلقائى فى تمام الساعة الواحدة ظهراً تكون بهذا الشكل (01:00:00 م ) وفي حالة ضبط إعدادت الوقت فى نظام التشغيل 24 ساعة يكون التسيق (HH:MM:SS) مثال عندما نريد نسخ تلقائى فى تمام الساعة الواحدة ظهراً تكون بهذا الشكل (13:00:00) ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ ملاحظـــــة هامــــــــة ـــــــــــــــــــــــــــــــــــ لكى يتم عمل النسخ التلقائي لقواعد البيانات بشكل تلقائي طبقاً للإعدادت المسبقة 1- يجب فتح النموذج المسئول عن النسخ الإحتياطي التلقائي من خلال النقر على الزر "بدء النسخ الاحتياطي التلقائي" وإلا لن يتم النسخ الاحتياطى تلقائيا فى الوقت المحدد طبقاً للإعدادت المحددة 2- فى حالة إستخدام شاشة التوقف أو شاشة حماية إذا كنت ترغب فى الحصول على السرية والحماية للجهاز الخاص بك فى غيابك لن يؤثر ذلك على النسخ التلقائي ☺ ملاحظة هامة جدا جدا جدا يتم تحديد قاعدة بيانات أو أكثر لعمل نسخ احتياطى لها وضغط واصلاح مرة واحدة فقط من الاعدادت يتم تحديد المسار المراد حفظ النسخ الاحتياطى مرة واحدة فقط وقمت بعمل طريقة تجعل البرنامج يقوم كل يوم بعمل مجلد باسم وتاريخ اليوم دون اى تدخل من المستخدم فقط غير فتح النموذج "frmTimer" مشكلة لو تم وضع باسورد لحماية قاعدة البيانات المراد عمل نسخ احتياطى لها عند فتحها فلن يكتمل النسخ التلقائى الالى بسبب كلمة السر هذه ولن يتم عمل اى نسخ احتياطى لباقى قواعد البيانات الاخرى للامانة العلمية : هذا البرنامج حصلت عليه من احد المنتديات الاجنبية ولكن قمت بتعديلات كثيرة جدا للوصول الى هذه النتيجة المثمرة ان شاء الله واضعها بين أيديكم حتى تعم الفائدة AutoBackup.rar

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

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

السلام عليكم ورحمة الله وبركاته اكتب N=N+2 بدلا من N=N+1 ثم اضف Range("A" & N) = (N - 11) / 2 قبل عبارة End With

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

و عليكم السلام و رحمة الله و بركاته ... كما عودتنا دائما ... تغيب تغيب و تجيبلنا مفاجأة من العيار الثقيل ... سلمت يداك و زادك الله من علمه ...

ماشى يا كبيرنا مش بقولك مبتدأ فى اول الطريق

بعد اذن اخي ابو حنين نفس العمل لكن بالمعادلات ضع هذه المعادلة في الخلية D2 واسحب نزولاً =IF(MAX($D$1:D1)+1>$A$1,"",IF(MOD((ROWS($A$1:A1)-1),3)<>0,"",MAX($D$1:D1)+1)) للتوضيح المرفق في الحالة العامة (المرفق ) يجب وضع هذه المعادلة في الخلية D2 عندها يمكن تغيير القيمتين في A1 & F1 =IF(MAX($D$1:D1)+1>$A$1,"",IF(MOD((ROWS($A$1:A1)-1),$F$1+1)<>0,"",MAX($D$1:D1)+1)) تسلسل الى salim.rar

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

تم التحميل جزيت خيرا

الأخ الكريم عمر ضاحى السلام عليكم جرب المعادلة التالية ضعها فى c9 واسحبها نزولا =SUMPRODUCT(--('ALL-INF'!$I$3:$I$1000=Final!D9)*--('ALL-INF'!$E$3:$E$1000)) abo_abary_Sample.rar

جزاكم الله خيرا جارى التحميل والتجربة............................

استعمل هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 6 Then If Target.Row > 9 And Target.Row < 61 Then Target.Offset(, 3).Value = Target.Offset(, 2).Value * Target.Value [H61] = Application.WorksheetFunction.Sum(Range("I10:I60")) [H64] = [H61] + [H62] - [H63] End If End If End Sub

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

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

ياسر خليل أبو البراء اخى الفاضل ما شاء الله عليك

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

بارك الله فيك أخي الحبيب أبو حنين وجزيت خيراً على كل مساهماتك الرائعة والجميلة وبصراحة أنت ملك الفورم لي رجاء عندك ويا ريت تلبيه .. أرجو دائماً في كل مشاركاتك أن تضع الكود في المشاركة للإطلاع عليه قبل تحميل الملف أخي السائل (حتى منعرفش اسمه لحد الآن) روح للكود في الفورم وابحث عن هذا السطر Me.Controls("T" & I) = "" وغير I إلى xx ... ولي رجاء أن تقسم موضوعك إلى نقاط بسيطة لكي تجد الاستجابة من قبل إخوانك بالمنتدى (وراجع التوجيهات لتعرف كل الأمور التي يستحب الالتزام بها)

هذا توضيح بالصورة لما يريده الأخ السائل (داخل الخلية الواحدة) الأمر يحتاج لكود . فمن يسعفنا به ؟

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

حبيبى تسلم يا غالى ربنا يبارك فيك ويجعله فى ميزان حسناتك

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

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

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

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

السلام عليكم محاولة اتمنى ان يكون المطلوب واتمنى من الاخوة ان يبسط المعادلة المصنف1.rar

وانا ايضا لابد لي من تغير النظارة ملفك القوئم لا تعمل

وجزيت خيراً أخي الكريم أبو سلمان ببساطة يوضع سطر لفك الحماية في بداية الكود وفي نهاية الكود يوضع سطر لوضع الحماية مرة أخرى Activesheet.Unprotect 123 هذا السطرلفك الحماية بفرض أن كلمة السر 123 .... لإرجاع الحماية ستستخدم نفس السطر بالضبط وتحذف منه فقط حرفين Un ... أرجو أن يفي هذا بالغرض

عليكم السلام ورحمة الله وبركاتة الاخ الفاضل الاستاذ محمد طاهر اخي العزيز شكرا علي ترحيبك الكريم اما بخصوص افضل عدم ضم حسابي القديم و ان اظل عضو عادي بدون مسؤليات او صلاحيات واتاحة اللفرصة للشباب النشط ذو الجهد الملحوظ للترقي ارجو ان تتكرم بزيادة الحد المسموح للرفع لحسابي الحالي فتقابلني بعض الاحيان ملفات كبيرة مما اضطر لرفع الحل علي مواقع الرفع مما يفوت الفرصة بعد فترة علي الاعضاء في وجود المرفق علي موقع المنتدي اخي الكريم نعم رقم الهاتف القديم كما هو الاخ الفاضل الاستاذ محمد طاهر اعرف اني مقصر معك ارجو المعذرة ربما في المستقبل اخبرك بالاسباب شكرا لك مرة اخري علي ترحيبك

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

ريثما ترسل الملف شاهد هذا https://youtu.be/Rx4xaOs--Xs

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

و عليكم السلام و رحمة الله تعالى و بركاته كل عام و الأمة الإسلامية بخير إن شاء الله

شفت لما الموضوع بقا واضح لقيت الحل علطول إزاي ؟؟!! عشان متتعصبش علينا .. وامسك أعصابك يا أبو الفتوح يا روح الروح إليك المعادلة التالية وهي معادلة صفيف (يعني بعد ما تدخل المعادلة في الخلية الهدف قوم بالضغط على 3 مفاتيح مع بعض CTRL + SHIFT + ENTER) والحل دا هيغنيك عن استخدام أعمدة مساعدة =INDEX($D$2:$D$6,MATCH(C12&""&D12,$C$2:$C$6&""&$E$2:$E$6,0)) & "-" & INDEX($F$2:$F$6,MATCH(C12&""&D12,$C$2:$C$6&""&$E$2:$E$6,0)) لو حصل معاك خطأ غير الفاصلة العادية في المعادلة إلى فاصلة منقوطة ... والحمد لله أن تم المطلوب والموضوع على خير

الطريقة الثانية VB.rar

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

أخي الحبيب سليم بارك الله فيك وجزاك الله كل خير بينما كنت تقدم الحل لأخونا محمد السباعي كنت منهمك في الكود التالي (الذي تعدى معي حد الجنون ..!! أكثر من ساعة ونصف وربما ساعتين في هذا الكود) هو كود مجنون بحق .. حاولت فيه بقدر المستطاع أن أجعله كون مرن يصلح لأي موضوع شبيه بهذا الموضوع (خصوصاً أن هذا الموضوع يتكرر في كثير من الأحيان) وهو أن يكون هناك ورقة عمل رئيسية بها عمودوالمطلوب ترحيل القيم في هذا العمود إلى الورقة المناسبة ، وأضفنا إليه من قبل إمكانية إنشاء ورقة عمل إذا لم تكن موجودة .. الكود المجنون من العيار الثقيل وأرجو أن يبدي الأعضاء أي ملاحظات عليه لتطويره بحيث يصلح لهذه المشكلة أياً كان شكلها وحجمها وأبعادها ... الكود بالشكل التالي Sub Transfer_Data_Using_Filter_By_List() 'Author : YasserKhalil 'Release : 01 - 09 - 2016 '------------------------ Dim dictPerson As Object, dictSheet As Object, mtx(), isFound As Boolean Dim I As Long, v1 As Variant, v2 As Variant, arr As Variant, arrCol As Variant Dim rng As Range, arrHeader As Variant Dim cnt As Integer, counter As Integer Dim Rc As Long, Gc As Long, Bc As Long '=========================================================================================== 'Column Number To Be Filtered Const iCol As Integer = 5 'Sheet Name (The Source Sheet) Const sSheet As String = "DATA" 'Data Range Including Header Set rng = Sheets(sSheet).Range("A5:E" & Sheets(sSheet).Cells(Rows.Count, iCol).End(xlUp).Row) 'Row Number For Destination Sheets (5 = Row 5) Const destRow As Integer = 5 'Column Number For Destination Sheets (1 = Column A) Const destCol As Integer = 1 'Column Widths For Output Sheets arr = Array(14, 50, 15, 14) 'Columns Order To Be Copied. So Column 4 In Data Sheet To Be Copied To Column 1 To Destination Sheet arrCol = Array(4, 3, 1, 2) 'Columns Order To Be Copied. So Column 4 In Data Sheet To Be Copied To Column 1 To Destination Sheet arrHeader = Array("القيمة", "البيان", "التوجيه المحاسبي", "التاريخ") '=========================================================================================== Application.ScreenUpdating = False mtx = rng.Value Set dictPerson = CreateObject("Scripting.Dictionary") For I = 2 To UBound(mtx, 1) If Not dictPerson.Exists(mtx(I, iCol)) Then dictPerson.Add mtx(I, iCol), mtx(I, iCol) Next I Set dictSheet = CreateObject("Scripting.Dictionary") For I = 1 To Worksheets.Count If Not dictSheet.Exists(Worksheets(I).Name) Then dictSheet.Add Worksheets(I).Name, Worksheets(I).Name Next I dictSheet.Remove (sSheet) For Each v1 In dictPerson isFound = False For Each v2 In dictSheet If v1 = v2 Then isFound = True Exit For End If Next v2 If Not isFound Then If MsgBox(v1 & " Does Not Exist." & vbCrLf & "Create This Sheet ? ", vbOKCancel) = vbOK Then Worksheets.Add After:=Sheets(sSheet) ActiveSheet.Name = v1 ActiveSheet.DisplayRightToLeft = True Else dictPerson.Remove v1 End If End If Next v1 For Each v1 In dictPerson Sheets(v1).Cells.Clear rng.AutoFilter Field:=iCol, Criteria1:=v1 With rng.Offset(1) For counter = LBound(arrCol) To UBound(arrCol) .Columns(arrCol(counter)).SpecialCells(xlCellTypeVisible).Copy Sheets(v1).Cells(destRow + 1, destCol + counter).PasteSpecial xlPasteValues Sheets(v1).Columns(destCol + counter).NumberFormat = .Columns(arrCol(counter)).NumberFormat Next counter Sheets(v1).Cells(destRow, destCol).Resize(1, UBound(arrHeader) + 1).Value = arrHeader End With With rng(1, 1) Rc = .Interior.Color Mod 256 Gc = Int(.Interior.Color / 256) Mod 256 Bc = Int(Int(.Interior.Color / 256) / 256) Sheets(v1).Cells(destRow, destCol).Resize(1, UBound(arrHeader) + 1).Interior.Color = RGB(Rc, Gc, Bc) End With With Sheets(v1) With .Cells .ReadingOrder = xlRTL .Font.Name = "Arial" .Font.Size = 11 .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter .RowHeight = 19 .ColumnWidth = 9 End With With .Cells(destRow - 1, destCol) .Offset(1).CurrentRegion.Borders.Value = 1 .Value = v1 .Resize(1, UBound(arrHeader) + 1).Interior.Color = vbYellow .Resize(1, UBound(arrHeader) + 1).HorizontalAlignment = xlCenterAcrossSelection End With With .Rows(destRow - 1).Resize(2) .RowHeight = 25 .Font.Bold = True .Font.Size = 13 End With For cnt = LBound(arr) To UBound(arr) .Columns(destCol + cnt).ColumnWidth = arr(cnt) Next cnt Application.Goto .Range("A1") End With Next v1 Application.Goto Sheets(sSheet).Range("A1") rng.AutoFilter Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub فمت بوضع التعليقات باللغة الإنجليزية (معلش تعود مش أكتر) سأقوم بشرحها لمن يهمه الأمر أول سطر في التعليق يتعلق برقم العمود الذي يحتوي على القيم التي سيتم فلترتها السطر التالي يكتب اسم ورقة العمل التي تحتوي على البيانات (الورقة الرئيسية) السطر التالي نطاق البيانات المراد العمل عليها السطر التالي رقم الصف المراد وضع البيانات فيه السطر التالي رقم العمود المراد وضع البيانات فيه .. مثال لو أردنا وضع البيانات في الخلية H3 هذا يعني أن رقم الصف هو 3 ورقم العمود هو 8 السطر التالي عرض الأعمدة في المخرجات ..بما أننا تعاملنا في المخرجات مع 4 أعمدة فيكتب 4 أرقام ..يمكنك ببساطة زيادة أو نقصان العدد السطر التالي ترتيب الأعمدة وهذا السطر مهم للغاية ..فقد لاحظت أن الترتيب ليس بالضبط كترتيب الورقة الرئيسية وهذا ما دفعني إلى كتابة الكود في الحقيقة .. المهم هنا الرقم 4 هو رابع عمود في ورقة البيانات ، والرقم 3 هو ثالث عمود في ورقة البيانات ، والرقم 1 أول عمود في ورقة البيانات ، والرقم 2 هو ثاني عمود في ورقة البيانات ، وسيتم ترحيلهم بنفس الترتيب إلى الأوراق الجديدة السطر التالي هو خاص بالعناوين التي ستوضع في الأوراق الأخرى والتي سيتم ترحيل البيانات إليها ، وقد قمت بذلك أيضاً لأنني لاحظت أن هناك تغيير في العناوين (العمود "مدين" يسمى في المخرجات باسم "القيمة") المهم الأربعة سطور الأخيرة يجب أن يكون كل منها محتوي على 4 عناصر حسب عدد الأعمدة المطلوبة في المخرجات أسأل الله العظيم أن يكون الكود مفيد لكم وأعتذر عن الإطالة .. ولكن كان لابد من التوضيح التام لما هو مهم في الكود لتتمكنوا من استخدامه بسهولة ويسر .. لتجربة الكود بشكل أعمق اختر في الخلية E12 ايصال تسوية ، وهي ورقة عمل غير موجودة لتشاهد ورقة العمل وهي تنشأ وتوضع فيها البيانات .. ولك الحرية في تلك النقطة (لك أن تنشيء ورقة العمل أو تلغي ... لابد أن يكون هناك مرونة) تقبلوا وافر تقديري واحترامي رابط الملف المرفق من هنا

أين المرفق أخي الكريم حسين؟

السلام عليكمعلى الوعد نلتقىفى يوم الجمعة المباركمع فيديوهات شرح موضوعات احترافية فى قواعد بيانات أكسيسيمكنكم تطبيق الشرح على أكسيس 2010 20132016فالجوهر واحدو إن اختلف الشكلفيديو اليومتريد أن تنتقل بين السجلات ليس بمقدار سجل واحد للأمام و سجل للخلفبل بمقدار عدد من السجلات تحدده أنتهذا الفيديو هو طلبكمع الكود البسيطالفيديوhttps://youtu.be/I3e3O_xG5C8