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

[الشيباني1]

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

Book1.zip

[طارق محمود]

السلام عليكم

أخي الكريم

جرب الكود التالي

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'Next g

If Target.Row < 17 Then Exit Sub

tgc = Target.Column

If tgc <> 3 And tgc <> 7 And tgc <> 8 And tgc <> 15 Then Exit Sub

Dim pc As Range

Set pc = Sheets(2).Range("prices")

lastR = [D10000].End(xlUp).Row

For i = 18 To lastR

If Cells(i, "D") <> "" Then

	Cells(i, "C") = WorksheetFunction.CountA(Range("D18:D" & i))

	Cells(i, "O") = WorksheetFunction.VLookup(Cells(i, "D"), pc, 2, 0)


	If Cells(i, "P") = "" Then

    	Cells(i, "G") = Cells(i, "O")

	Else

    	Cells(i, "G") = Cells(i, "P")

	End If


	Cells(i, "H") = Cells(i, "F") * Cells(i, "G")


End If


Next i


End Sub

في حدث الورقة (الرئيسية)

لكن لابد من إلغاء الكود الموجود بها

تفضل المرفق

Equations_2_Codes.rar

[الشيباني1]

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

[طارق محمود]

السلام عليكم

أخي الكريم

بدل الكود بالتالي (امسح القديم وضع هذا)

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Row < 17 Then Exit Sub

tgc = Target.Column

tgr = Target.Row

If tgc <> 4 And tgc <> 6 And tgc <> 9 And tgc <> 16 Then Exit Sub

If WorksheetFunction.CountA(Range("D" & tgr & ":F" & tgr)) < 2 Then Exit Sub

Dim pc As Range

Set pc = Sheets(2).Range("prices")

lastR = [D10000].End(xlUp).Row

For i = 18 To lastR

If Cells(i, "D") <> "" Then

	Cells(i, "C") = WorksheetFunction.CountA(Range("D18:D" & i))

	Cells(i, "O") = WorksheetFunction.VLookup(Cells(i, "D"), pc, 2, 0)


	If Cells(i, "P") = "" Then

    	Cells(i, "G") = Cells(i, "O")

	Else

    	Cells(i, "G") = Cells(i, "P")

	End If


	Cells(i, "H") = Cells(i, "F") * Cells(i, "G")


End If


Next i

End Sub

[ياسر الحافظ]

الاستاذ طــــــــــــــارق :

عمل محترفين بصحيح ... استفدت جدا جدا منه

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

وفقك الله

ياسر الحافظ " ابو الحارث "

[الشيباني1]

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

[طارق محمود]

السلام عليكم

الكود يعمل جيدا علي الملف الذي معي

إنسخه مرة أخري

لعلك أخذت نسخة قبل التعديل

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

أنظر الفيديوالمرفق

Equations_2_Codes.rar

[طارق محمود]

السلام عليكم

أخي الكريم ابا الحارث

أسعدني وشرفني مرورك العظيم

دمت في ود

[الشيباني1]

استاذنا العزيز مع شكري وتقديري الكود يعمل بعد تعديلكم الاخير ولكن تظهر هذه الرساله في الفيجوال بيسك (Run-time error 1004: WorksheetFunction من الفئة Vlookupلايمكن الحصول على الخاصية وعند الضغط عاى (Debug)في الرسالة يتلون السطر

Cells(i, "O") = WorksheetFunction.VLookup(Cells(i, "D"), pc, 2, 0)باللون الاصفر ارجو المساعده لان الكود رائع جدا ويخدم عملي كثيرا مع الامتنان

[طارق محمود]

السلام عليكم

معني الرسالة أنك وضعت قيمة في العمود D ليست موجودة في جدول اللوك أب والله أعلم

يمكنك إضافة السطر التالي في الكود ليتفادي مثل هذا الخطأ

On Error Resume Next

ليكون كالتالي

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Row < 17 Then Exit Sub

tgc = Target.Column

tgr = Target.Row

If tgc <> 4 And tgc <> 6 And tgc <> 9 And tgc <> 16 Then Exit Sub

If WorksheetFunction.CountA(Range("D" & tgr & ":F" & tgr)) < 2 Then Exit Sub

On Error Resume Next

Dim pc As Range

....

...

ولكن جرب أولا ال نتائج إذا لم تكن القيمة في العمود D موجودة في جدول اللوك أب

[الحسامي]

السلام عليكم

اخي الكريم لاثراء الموضوع وتعدد الحلول وبعد اذن المهندس طارق

هنا حل اخر

If Not Intersect(Target, [d18:f39,p18:p39]) Is Nothing Then

On Error Resume Next

Dim x As Integer

x = Target.Row

Cells(x, "o") = Application.WorksheetFunction.VLookup(sheet1.Cells _

(x, "d") + 0, sheet2.Range("prices"), 2, 0)

Cells(x, "g") = Cells(x, "p")

If Cells(x, "p") = Empty Then Cells(x, "g") = Cells(x, "o")

Cells(x, "h") = Cells(x, "f") * Cells(x, "g")

Cells(x, "c") = x - 17

End If

code1.rar

تم تعديل أغسطس 12, 2011 بواسطه الحسامي

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

ما شاء الله

الاساتذة الكرام

طارق محمود

عماد الحسامي

اعمال مميزة وابداع متواصل

عسى الله لا يحرمنا من خبراتكم الكبيره

ابواحمد

[saad abed]

ما شاء الله

الاساتذة الكرام طارق محمود

عماد الحسامي

اعمال مميزة وابداع متواصل

عسى الله لا يحرمنا من خبراتكم الكبيره

ابواحمد

اخى واستاذى/ طارق محمود

اخى وحبيبى / عماد خالد الحسامى

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

شكرا لكم وكل عام وانتم بخير

سعد عابد

[الشيباني1]

اساتذتنا الكبار ابداع ما بعده ابداع جزاكم الرحمن كل خير وادامكم مرجعا لنا

[يوسف عطا]

الله ينور عليكم

برجاء دمج الموضوعين