اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


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

السلام عليكم

أخي الكريم

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


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

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

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

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

السلام عليكم

أخي الكريم

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



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

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

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

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

السلام عليكم

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

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

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

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

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

Equations_2_Codes.rar

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

استاذنا العزيز مع شكري وتقديري الكود يعمل بعد تعديلكم الاخير ولكن تظهر هذه الرساله في الفيجوال بيسك (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

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

ما شاء الله

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

طارق محمود

عماد الحسامي

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

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

ابواحمد

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

ما شاء الله

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

عماد الحسامي

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

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

ابواحمد

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

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

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

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

سعد عابد

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

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

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



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

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

Important Information