اذهب الي المحتوي
أوفيسنا

(تمت الإجابة) كيف أجعل البرنامج يختار أحسن نتيجة من الجدول

أبو أريج

بواسطه أبو أريج
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

أبو أريج

أبو أريج

قام بنشر
قام بنشر

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

عيد سعيد للجميع

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

بارك الله فيكم مسبقا

compression.rar

رابط هذا التعليق
شارك
طارق محمود

طارق محمود

قام بنشر
قام بنشر

السلام عليكم

أخي الكريم

تفضل المرفق به الحل

باستخدام التنسيق الشرطي

الشرط الأول يلون بالأحمر كل مافي الجدول ويزيد عن أو يساوي المساحة المطلوبة Asc

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

المرفق علي الرابط

http://www.4shared.com/file/Lj37HIJz/compression_TAREQ.html

رابط هذا التعليق
شارك
طارق محمود

طارق محمود

قام بنشر
قام بنشر

أخي الفاضل

لقد أرفقت هنا ملفا آخر به حل أفضل :rol:

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

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

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

القيمة المطلوبة هي المقابلة لأكبر رقم في الجدول المساعد

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

حيث مساحة الواحد =

(PI).D[sup]2[/sup]/400

PI هي النسبة التقريبية

تستطيع تغيير الأرقام لتتغير قيمة المساحة المطلوبة Asc

لتشاهد الفرق أوتوماتيكيا

المرفق علي الرابط

http://www.4shared.c...ion_TAREQ2.html

رابط هذا التعليق
شارك
أبو أريج

أبو أريج

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم

عفوا نسيت أن أسألك كيف تحصلت على اللون الباهت للجدول و الأرقام و كيفية استبدال العلامة 0 بالعلامة(-) و هل يمكن استعمال التنسيق الشرطي لتلوين خانة أكبر عدد (max) ؟

رابط هذا التعليق
شارك
طارق محمود

طارق محمود

قام بنشر
قام بنشر

اللون الباهت للجدول و الأرقام من ايكونة الألوان إختر مايعجبك

إستبدال العلامة 0 بالعلامة(-) من تنسيق الأرقام

طبعا ممكن استعمال التنسيق الشرطي لتلوين خانة أكبر عدد (max) وهذا ماتم في الملف الثاني راجعه مرة أخري

رابط هذا التعليق
شارك
طارق محمود

طارق محمود

قام بنشر
قام بنشر

لاعليك أخي الفاضل

راجع الملف واسأل كما يحلو لك

وأزيدك أنه ممكن أيضا التنويع كما هو الحال في الواقع

بمعني مثلا إذا كانت مساحة الحديد المطلوب = 10.60 سم2

فمن الممكن أن يختار البرنامج 4 قطر 12 + 4 قطر 14 ليكون 10.67 بدلا من إختيار 10 قطر 12 وهي الأقرب في الجدول 11.31سم2

ولكن هذا قد يحتاج كود صغير

رابط هذا التعليق
شارك
أبو أريج

أبو أريج

قام بنشر
  • الكاتب
قام بنشر

بسم الله الرحمن الرحيم

إنها حلول رائعة و قد أسرتني حقا . بارك اله فيك أستاذي طارق و ألف شكر

مع كامل إحتراماتي و تقديري

طلب أخير إن سمحت:

هل يمكن أن تجعل عدد القضبان المختارة عدد زوجي لأنه تسليح عمود خرساني :signthankspin:

رابط هذا التعليق
شارك
طارق محمود

طارق محمود

قام بنشر
قام بنشر

السلام عليكم

ممكن تجعل الخطوة ثنائية في حلقة عداد الكميات

بإضافة جملة Step 2

لآخر كل سطر يبدأ بـ For q أو For qq

وسيكون الكود النهائي هكذا


Private Sub Worksheet_Calculate()

Application.ScreenUpdating = False

Dim dia(99), d As Integer, A(99, 99) As Double

i = 0

For d = 10 To 40 Step 2

    If d = 26 Or d = 34 Or d = 36 Or d = 38 Then GoTo 10

    If d = 24 Then i = i + 1: dia(i) = 25: GoTo 10

    i = i + 1

    dia(i) = d

10 Next d

For q = 2 To 12

    For i = 1 To 12

		    A(q, i) = Round(q * dia(i) ^ 2 / 400 * WorksheetFunction.Pi, 2)

		    'Cells((q - 1) * 12 + i, "V") = "A(" & q & "dia-" & dia(i) & ")"

		    'Cells((q - 1) * 12 + i, "W") = A(q, i)

    Next i


Next q

A_min = 2 * [S4] / 100

For q = 2 To 12 Step 2

    For i = 1 To 12

	    For qq = 2 To 12 Step 2

		    For ii = 1 To 12

			    If ii = i Then GoTo 20

			    If (A(q, i) + A(qq, ii)) < [S4] / 100 Then GoTo 20

			    If (A(q, i) + A(qq, ii)) > 1.5 * [S4] / 100 Then GoTo 20

			    If (A(q, i) + A(qq, ii)) < A_min Then

				    A_min = A(q, i) + A(qq, ii)

				    Chosn = q & "f" & dia(i) & " + " & qq & "f" & dia(ii) & " = " & A_min

				    q1 = q: d1 = dia(i): q2 = qq: d2 = dia(ii)

			    End If

20		  Next ii


	    Next qq

    Next i


Next q


For q = 2 To 12 Step 2

    For i = 1 To 12

	    If A(q, i) < [S4] / 100 Then GoTo 30

	    If A(q, i) > 1.5 * [S4] / 100 Then GoTo 30

	    If A(q, i) < A_min Then

		    A_min = A(q, i) + A(qq, ii)

		    Chosn = q & "f" & dia(i) & " = " & A_min

		    q1 = q: d1 = dia(i): q2 = 0: d2 = 0

	    End If

30  Next i

Next q

[S6] = Chosn

[E5:P16].Interior.ColorIndex = xlNone

cc1 = WorksheetFunction.Match(q1, [E4:P4], 0)

rr1 = WorksheetFunction.Match(d1, [Q5:Q16], 0)

Cells(rr1 + 4, cc1 + 4).Interior.ColorIndex = 3

If q2 = 0 Then GoTo 55

    cc2 = WorksheetFunction.Match(q2, [E4:P4], 0)

    rr2 = WorksheetFunction.Match(d2, [Q5:Q16], 0)

    Cells(rr2 + 4, cc2 + 4).Interior.ColorIndex = 3

55

Application.ScreenUpdating = True

End Sub

رابط هذا التعليق
شارك
طارق محمود

طارق محمود

قام بنشر
قام بنشر

السلام عليكم

مازال الملف ليس بالكمال المطلوب

أعلم أن الأفضل أن تكون الأقطار متقاربة

فلايجوز مثلا ان تستخدم قطر 12 ، 20

الأفضل أن يكون فارق درجة واحدة أو إثنين علي الأكثر

ولكن إلي السبت القادم إن شاء الله

رابط هذا التعليق
شارك
طارق محمود

طارق محمود

قام بنشر
قام بنشر

السلام عليكم

أخي العزيز

فقط اضف السطر التالي في حلقة الإختيار

If Abs(i - ii) > 2 Then GoTo 20

ليكون الكود في النهاية هكذا


Private Sub Worksheet_Calculate()

Application.ScreenUpdating = False


Dim dia(99), d As Integer, A(99, 99) As Double

i = 0

For d = 10 To 40 Step 2


	If d = 26 Or d = 34 Or d = 36 Or d = 38 Then GoTo 10

	If d = 24 Then i = i + 1: dia(i) = 25: GoTo 10

	i = i + 1

	dia(i) = d

10 Next d


For q = 2 To 12

	For i = 1 To 12

			A(q, i) = Round(q * dia(i) ^ 2 / 400 * WorksheetFunction.Pi, 2)


	Next i


Next q


A_min = 2 * [S4] / 100


For q = 2 To 12 Step 2

	For i = 1 To 12

		For qq = 2 To 12 Step 2

			For ii = 1 To 12

				If ii = i Then GoTo 20

				If (A(q, i) + A(qq, ii)) < [S4] / 100 Then GoTo 20

			    If Abs(i - ii) > 2 Then GoTo 20' هذا هو السطر المضاف

				If (A(q, i) + A(qq, ii)) > 1.5 * [S4] / 100 Then GoTo 20

				If (A(q, i) + A(qq, ii)) < A_min Then

					A_min = A(q, i) + A(qq, ii)

					Chosn = q & "f" & dia(i) & " + " & qq & "f" & dia(ii) & " = " & A_min

					q1 = q: d1 = dia(i): q2 = qq: d2 = dia(ii)

				End If

20		  Next ii


		Next qq

	Next i


Next q



For q = 2 To 12 Step 2

	For i = 1 To 12

		If A(q, i) < [S4] / 100 Then GoTo 30

		If A(q, i) > 1.5 * [S4] / 100 Then GoTo 30

		If A(q, i) < A_min Then

			A_min = A(q, i) + A(qq, ii)

			Chosn = q & "f" & dia(i) & " = " & A_min

			q1 = q: d1 = dia(i): q2 = 0: d2 = 0

		End If

30  Next i

Next q

[S6] = Chosn


[E5:P16].Interior.ColorIndex = xlNone


cc1 = WorksheetFunction.Match(q1, [E4:P4], 0)

rr1 = WorksheetFunction.Match(d1, [Q5:Q16], 0)

Cells(rr1 + 4, cc1 + 4).Interior.ColorIndex = 3


If q2 = 0 Then GoTo 55

	cc2 = WorksheetFunction.Match(q2, [E4:P4], 0)

	rr2 = WorksheetFunction.Match(d2, [Q5:Q16], 0)

	Cells(rr2 + 4, cc2 + 4).Interior.ColorIndex = 3


55

Application.ScreenUpdating = True


End Sub

رابط هذا التعليق
شارك
أبو أريج

أبو أريج

قام بنشر
  • الكاتب
قام بنشر

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

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

* للمساحة مثلا 12.30 cm² كانت النتيجة(2f28 = 12,32) أي 2 قضبان ذات قطر 28 مم ؟ و السؤال هل يمكن تحديد أدنى عدد هو 4 و ألا يزيد مثلا عن 8 أو عشرة (4-6-8-10)

* أدنى قطر للتسليح هو 12mm : لقد استبدلت في الكود ما يلي For d = 10 To 40 Step 2 و جعلته For d = 12 To 40 Step 2 هل هذا كافي؟

سامحني إن أثقلت عليك

رابط هذا التعليق
شارك
طارق محمود

طارق محمود

قام بنشر
قام بنشر

السلام عليكم

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

يقوم بعمل حد أدني للإختيار 4 قضبان وحد أعلي للإختيار 12 قضيب

وكذلك الأقطار تبدأ من 12

تفضل الكود

Private Sub Worksheet_Calculate()

Application.ScreenUpdating = False


Dim dia(99), d As Integer, A(99, 99) As Double

i = 0

For d = 12 To 40 Step 2


    If d = 26 Or d = 34 Or d = 36 Or d = 38 Then GoTo 10

    If d = 24 Then i = i + 1: dia(i) = 25: GoTo 10

    i = i + 1

    dia(i) = d

10 Next d


For q = 1 To 12

    For i = 1 To 11

		    A(q, i) = Round(q * dia(i) ^ 2 / 400 * WorksheetFunction.Pi, 2)

    Next i


Next q


A_min = 2 * [S4] / 100

For q = 2 To 12 Step 2

    For i = 1 To 11

	    For qq = 2 To 12 Step 2

		    For ii = 1 To 11

			    If ii = i Then GoTo 20

			    If (A(q, i) + A(qq, ii)) < [S4] / 100 Then GoTo 20

			    If Abs(i - ii) > 2 Then GoTo 20

			    If (A(q, i) + A(qq, ii)) > 1.5 * [S4] / 100 Then GoTo 20

			    If (A(q, i) + A(qq, ii)) < A_min And (q + qq) > 3 And (q + qq) < 12 Then

				    A_min = A(q, i) + A(qq, ii)

				    Chosn = q & "f" & dia(i) & " + " & qq & "f" & dia(ii) & " = " & A_min

				    q1 = q: d1 = dia(i): q2 = qq: d2 = dia(ii)

			    End If

20		  Next ii


	    Next qq

    Next i


Next q



For q = 2 To 12 Step 2

    For i = 1 To 11

	    If A(q, i) < [S4] / 100 Then GoTo 30

	    If A(q, i) > 1.5 * [S4] / 100 Then GoTo 30

	    If A(q, i) < A_min And q > 3 And q < 12 Then

		    A_min = A(q, i) + A(qq, ii)

		    Chosn = q & "f" & dia(i) & " = " & A_min

		    q1 = q: d1 = dia(i): q2 = 0: d2 = 0

	    End If

30  Next i

Next q

[S6] = Chosn


[E5:P16].Interior.ColorIndex = xlNone


cc1 = WorksheetFunction.Match(q1, [E4:P4], 0)

rr1 = WorksheetFunction.Match(d1, [Q5:Q16], 0)

Cells(rr1 + 4, cc1 + 4).Interior.ColorIndex = 3


If q2 = 0 Then GoTo 55

    cc2 = WorksheetFunction.Match(q2, [E4:P4], 0)

    rr2 = WorksheetFunction.Match(d2, [Q5:Q16], 0)

    Cells(rr2 + 4, cc2 + 4).Interior.ColorIndex = 3


55

Application.ScreenUpdating = True


End Sub

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept