الشيباني1 قام بنشر أغسطس 10, 2011 قام بنشر أغسطس 10, 2011 اخواني الاعزاء تحية رمضانية مباركة ارجو المساعده باكواد بدل المعادلات التي تتضمنها الاعمده الملونه بالاصفر في المرفق لحاجتي الماسة اليها مع الامتنان Book1.zip
طارق محمود قام بنشر أغسطس 11, 2011 قام بنشر أغسطس 11, 2011 السلام عليكم أخي الكريم جرب الكود التالي 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 قام بنشر أغسطس 11, 2011 الكاتب قام بنشر أغسطس 11, 2011 استاذنا العزيز اشكرك جدا على هذا الكود الرائع الذي ليس بغريب على عملاق مثلكم في هذا المنتدى البديع ما اتساءل عنه امكانية ان يعمل الكود بشكل مباشر بمجرد ادخال المواد او بزر عوضا عن الدبل كليك الذي قد يسبب بعض المشاكل عند نسيان فعله مع الامتنان
طارق محمود قام بنشر أغسطس 11, 2011 قام بنشر أغسطس 11, 2011 السلام عليكم أخي الكريم بدل الكود بالتالي (امسح القديم وضع هذا) 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
ياسر الحافظ قام بنشر أغسطس 11, 2011 قام بنشر أغسطس 11, 2011 الاستاذ طــــــــــــــارق : عمل محترفين بصحيح ... استفدت جدا جدا منه جزاك الله كل الخير وفقك الله ياسر الحافظ " ابو الحارث "
الشيباني1 قام بنشر أغسطس 11, 2011 الكاتب قام بنشر أغسطس 11, 2011 استاذنا العزيز مع شكري وتقديري تم احلال الكود الجديد محل القديم ولكن لم يعمل لسبب اجهله رغم تغيير اسم الورقة في الكود الى ( ورقة3) اكون ممتنا لو تم تطبيق الكود على مثالي مع جزيل احترامي
طارق محمود قام بنشر أغسطس 11, 2011 قام بنشر أغسطس 11, 2011 السلام عليكم الكود يعمل جيدا علي الملف الذي معي إنسخه مرة أخري لعلك أخذت نسخة قبل التعديل حيث أنني اكتشفت شيئا وعدلته بعدما أرسلت المشاركة أنظر الفيديوالمرفق Equations_2_Codes.rar
طارق محمود قام بنشر أغسطس 11, 2011 قام بنشر أغسطس 11, 2011 السلام عليكم أخي الكريم ابا الحارث أسعدني وشرفني مرورك العظيم دمت في ود
الشيباني1 قام بنشر أغسطس 11, 2011 الكاتب قام بنشر أغسطس 11, 2011 استاذنا العزيز مع شكري وتقديري الكود يعمل بعد تعديلكم الاخير ولكن تظهر هذه الرساله في الفيجوال بيسك (Run-time error 1004: WorksheetFunction من الفئة Vlookupلايمكن الحصول على الخاصية وعند الضغط عاى (Debug)في الرسالة يتلون السطر Cells(i, "O") = WorksheetFunction.VLookup(Cells(i, "D"), pc, 2, 0)باللون الاصفر ارجو المساعده لان الكود رائع جدا ويخدم عملي كثيرا مع الامتنان
طارق محمود قام بنشر أغسطس 11, 2011 قام بنشر أغسطس 11, 2011 السلام عليكم معني الرسالة أنك وضعت قيمة في العمود 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 موجودة في جدول اللوك أب
الحسامي قام بنشر أغسطس 12, 2011 قام بنشر أغسطس 12, 2011 (معدل) السلام عليكم اخي الكريم لاثراء الموضوع وتعدد الحلول وبعد اذن المهندس طارق هنا حل اخر 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 بواسطه الحسامي
عبدالله المجرب قام بنشر أغسطس 12, 2011 قام بنشر أغسطس 12, 2011 ما شاء الله الاساتذة الكرام طارق محمود عماد الحسامي اعمال مميزة وابداع متواصل عسى الله لا يحرمنا من خبراتكم الكبيره ابواحمد
saad abed قام بنشر أغسطس 12, 2011 قام بنشر أغسطس 12, 2011 ما شاء الله الاساتذة الكرام طارق محمود عماد الحسامي اعمال مميزة وابداع متواصل عسى الله لا يحرمنا من خبراتكم الكبيره ابواحمد اخى واستاذى/ طارق محمود اخى وحبيبى / عماد خالد الحسامى اذا اجتمع العمالقة فان الطلبةومحبى العلم امثالى تجد استفاده كبيره شكرا لكم وكل عام وانتم بخير سعد عابد
الشيباني1 قام بنشر أغسطس 13, 2011 الكاتب قام بنشر أغسطس 13, 2011 اساتذتنا الكبار ابداع ما بعده ابداع جزاكم الرحمن كل خير وادامكم مرجعا لنا
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.