(تمت الاجابة) برجاء المساعدة بكود يقوم بترحيل البيانات بناء على ثلاث شروط

[فضل حسين]

الى خبراء واعضاء منتداى العزيز والعظيم

سلام الله عليكم ورحمته وبركاته

مرفق ملف موضح به المطلوب وجزاكم الله كل خير

الترحيل بناء على ثلاث شروط.rar

تم تعديل مارس 28, 2012 بواسطه فضل 1

[الخالدي]

السلام عليكم

جرب الكود

Sub AL_KHALEDI()

Array1 = Array("A", "B", "C", "D", "E", "F")

Array2 = Array("B", "D", "G", "H", "I", "J")

Range("A2:F" & Range("A10000").End(xlUp).Row).ClearContents

s = 1

For r = 2 To Sheets("Sheet1").Range("A10000").End(xlUp).Row

   x = 0

   x = x + Application.CountIf(Sheets("Sheet1").Cells(r, "C"), [I2])

   x = x + Application.CountIf(Sheets("Sheet1").Cells(r, "D"), [J2])

   x = x + Application.CountIf(Sheets("Sheet1").Cells(r, "J"), [K2])

   If x = 3 Then

	  s = s + 1

	  For A = 0 To 5

		 Cells(s, Array1(A)).Value = Sheets("Sheet1").Cells(r, Array2(A)).Value

	  Next A

   End If

Next r

End Sub

الترحيل بناء على ثلاث شروط1.rar

تم تعديل مارس 29, 2012 بواسطه الخالدي

[فضل حسين]

ساحر الاكسل ..... الخالدى باشا

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

ساحر الاكسل ............ الخالدى باشا

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

اريد من سيادتك

الحل ولكن بالمعادلات

شرح هذا الامر الموجود بالكود Range("A2:F5" & Range("A10000").End(xlUp).Row).ClearContents

وكلى شوق ولهفة منتظر ردك على المشاركة

على ان تسامحنى للمرة الثانية وتعذرنى على عدم قدرتى على انهاء المشاركة معك واستمتع دائما بأعمالك

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

احبك فى الله

فضل

تم تعديل مارس 28, 2012 بواسطه فضل 1

[الخالدي]

السلام عليكم ورحمة الله وبركاته

اخي فضل

أحبك الله الذي أحببتني له

وشكرا على الثناء الطيب

وبالنسبة لشرح

Range("A2:F5" & Range("A10000").End(xlUp).Row).ClearContents

السطر فيه خطاء مني فالصحيح A2:F بدلا من A2:F5 واعتقد ان الامر واضح الان بعد التصحيح , والأمر طبعا خاص بمسح خلايا النطاق حتى اخر خلية غير فارغة ايضا ارجوا تصحيح السطر

For r = 1 To Sheets("Sheet1").Range("A10000").End(xlUp).Row

بتصحيح الرقم 1 بالرقم 2

واعتذر عن الأخطاء بسبب الاستعجال خوفا من انقطاع الكهرباء

اُعيد تصحيح الكود المعروض في المشاركة السابقة

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

في امأن الله

تم تعديل مارس 29, 2012 بواسطه الخالدي

[رجب جاويش]

بعد اذن أخى الفاضل / الخالدى

هذا كود آخر لإثراء الموضوع

Sub ragab()

Set mysh = Sheets("sheet1")

[a2:f100].ClearContents

	For i = 2 To 100

	   If mysh.Cells(i, 3) = [i2] And mysh.Cells(i, 4) = [j2] And mysh.Cells(i, 10) = [k2] Then

	   Cells([a1000].End(xlUp).Row + 1, 1) = mysh.Cells(i, 2): Cells([b1000].End(xlUp).Row + 1, 2) = mysh.Cells(i, 4)

	   Cells([c1000].End(xlUp).Row + 1, 3) = mysh.Cells(i, 7): Cells([d1000].End(xlUp).Row + 1, 4) = mysh.Cells(i, 8)

	   Cells([e1000].End(xlUp).Row + 1, 5) = mysh.Cells(i, 9): Cells([f1000].End(xlUp).Row + 1, 6) = mysh.Cells(i, 10)

	   End If

	Next i

End Sub

الترحيل بناء على ثلاث شروط.rar

[فضل حسين]

نجم الاكسل الساطع

الاستاذ الفاضل / رجب جاويش

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

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

نجم الاكسل الساطع

اسمح لى بخصوص كودك لى طلب اخر اريد ظهور message box فى حالة عدم وجود قسم تابع للمدرسة وعدم ظهور اى بيانات مرحلة . هذة الرسالة مفادها (ان لايوجد قسم تابع للمدرسة ) هذة نقطة .

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

اكرر شكرى وتقديرى لشخصكم الكريم وربنا يخليك لنا يانجم

[رجب جاويش]

أخى الكريم / فضل

جزاك الله كل خير

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

أما بخصوص الشكل التلقائى فهو من قائمة insert ثم shapes ثم اختيار الشكل المطلوب علما بأننى أعمل على أوفيس 2010

الترحيل بناء على ثلاث شروط 2.rar

[Ahmed Elbhiry]

احسنت استاذ رجب

[احمدزمان]

السلام عليكم و رحمة الله وبركاته

كل التحية و التقدير للأستاذ الفاضل الخالدي

ولا انسى الدالة الرائعة التي ساعدني بها سابقا- ارقام اللوحات

و التحية للأخ رجب

حل آخر لإثراء الموضوع

تم تسمية النطاقات

input =Sheet1!$A$1:$L$21

Order =Sheet2!$I$1:$K$2

Output =Sheet2!$A$1:$F$25

و وضع الكود التالي

Range("input").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _

	"Order"), CopyToRange:=Range("Output"), Unique:=False

يمكنك ترك اي شرط فارغ تظهر كل بياناته

اضغط Start

الترحيل بناء على ثلاث شروط.rar

[فضل حسين]

الاستاذ الفاضل / احمد زمان

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

اى يصبح فى كودك او حلك اسم نطاق واحد لمدى محدد واحد . ولايتكرر اسماء النطاقات لمدى واحد .

اكرر شكرى لسيادتكم داعيا لسيادتكم بالتوفيق .

[فضل حسين]

نجم الاكسل

رجب جاويش

الف شكر يانجم هاقول ايه غير انك نجم

نتقابل فى مشاركات اخرى ان شاء الله

[احمدزمان]

الاستاذ الفاضل / احمد زمان

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

اى يصبح فى كودك او حلك اسم نطاق واحد لمدى محدد واحد . ولايتكرر اسماء النطاقات لمدى واحد .

اكرر شكرى لسيادتكم داعيا لسيادتكم بالتوفيق .

العفو ياسيدي الفاض

و لكن مافهمت ايه المطلوب

ممكن توضح اكثر

[فضل حسين]

سيدى الفاضل / احمد زمان

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

بخصوص الملحوظة :- قم بفتح قائمة ادراج واختار اسم سوف يظهر لك مربع حوارى باسم ( الاسماء فى المصنف ) وسوف تجد فى هذا المربع الحوارى

اسماء النطاقات المستخدمة داخل ملف الاكسل . ملحوظتى ان يوجد مثلا اسم النطاق criteria ومداها هو فى الورقة رقم 2 من i1:k2

ويوجد ايضا اسم نطاق سيادتك قمت بعمله يأخذ نفس النطاق وهو النطاق order مداها ايضا فى الورقة رقم 2 من i2:k2.

وعلى نفس الحال اسم النطاق الذى سيادتك قمت بعمله واسمه input مداها نفس مدى اسم النطاق extract

وملحوظتى او انا مااريده

ان يكون موجود اسم نطاق واحد للمدى وليس اسمين لمدى واحد

او بمعنى اخر اريد ان اكتفى بأسماء نطاقاتك فقط فى الملف ولااريد مثلا اسم النطاق criteria ولا اسم النطاق extract

يارب اكون استطعت توصيل الفكرة

شاكر لسيادتكم للمرة الثانية واشكر اهتمامكم ودعائى لكم وللجميع بالتوفيق

[عبدالله المجرب]

السلام عليكم

حلول ممتازة من الاخوة الكرام

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

وكل الشكر للاساتذة الكرام على التنوع في الحلول

[احمدزمان]

السلام عليكم و رحمة الله وبركاته

اولا : حمدا لله على سلامة الوصول استاذ عبدالله

ونسأل الله ان يتقبل و عمرة مقبولة ان شاء الله

والله يعوض عليك في ما راح

اخي فضل

سيدى الفاضل / احمد زمان

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

بخصوص الملحوظة :- قم بفتح قائمة ادراج واختار اسم سوف يظهر لك مربع حوارى باسم ( الاسماء فى المصنف ) وسوف تجد فى هذا المربع الحوارى

اسماء النطاقات المستخدمة داخل ملف الاكسل . ملحوظتى ان يوجد مثلا اسم النطاق criteria ومداها هو فى الورقة رقم 2 من i1:k2

ويوجد ايضا اسم نطاق سيادتك قمت بعمله يأخذ نفس النطاق وهو النطاق order مداها ايضا فى الورقة رقم 2 من i2:k2.

وعلى نفس الحال اسم النطاق الذى سيادتك قمت بعمله واسمه input مداها نفس مدى اسم النطاق extract

وملحوظتى او انا مااريده

ان يكون موجود اسم نطاق واحد للمدى وليس اسمين لمدى واحد

او بمعنى اخر اريد ان اكتفى بأسماء نطاقاتك فقط فى الملف ولااريد مثلا اسم النطاق criteria ولا اسم النطاق extract

يارب اكون استطعت توصيل الفكرة

شاكر لسيادتكم للمرة الثانية واشكر اهتمامكم ودعائى لكم وللجميع بالتوفيق

هوة ممكن حل آخر

يتم استخدام تسمية النطاقات من داخل الكود بحيث لا تظهر في ابدا في قائمة F3

تم تعديل أبريل 1, 2012 بواسطه احمدزمان