لو يتكرم الإخوة بحل هذا الإشكال مع الشكر

[onlymanly]

عندي ملف.. عبارة عن بيان تعبئة .. يشمل غالبا على ما يزيد عن 300 صنف .. و أغلب الأوقات يتكرر الصنف في أكثر من موضع

نظرا لموضعه داخل الكراتين.. و عند تفريغ بيان التعبئة إلى فاتورة للبيع للعميل..يحدث في أغلب الأحيان خطأ في كتابة سعر الصنف

في بعض المواضع التي يتكرر فيها الصنف.. فيحتاج الشخص للمراجعة عند حدوث غلط في قيمة الفاتورة تباع للغلط في بيان التعبئة إلى وقت طويل

للمراجعى و اكتشاف الخطأ و موضعه بالنسبة للسعر أو للكمية كذلك .. ..

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

إشكال في بيان التعبئة.rar

[طارق محمود]

السلام عليكم

أخي العزيز

جرب المرفق

أو ضع الكود التالي في حدث الورقة

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


Dim myrange, a, b As Range, rep(99) As Integer


 On Error GoTo ErrHandler

 Application.EnableEvents = False

 rr = Target.Row

 x = [a1].Offset(rr - 1, 0)

 Set myrange = Range("A14:A64")

 Range("A14:L64").Interior.Pattern = xlNone

 i = 0

	For Each s In myrange

 	y = s.Value

 	If y = x Then

 	i = i + 1

 	Range("A" & s.Row, "L" & s.Row).Interior.ColorIndex = 4

 	rep(i) = s.Row

 	End If

	Next s

	For j = 1 To i

 	Set a = Range("H" & rep(j))


 	For nj = 1 To i

 	Set b = Range("H" & rep(nj))

 	If b.Value <> a.Value Then b.Interior.ColorIndex = 3


 	Next nj


	Next j


ErrHandler:

 Application.EnableEvents = True

End Sub

 

onlyman-2.rar

[طارق محمود]

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

وإذا كان UNIT PRICE لها غير متساوي مثل M1 أو M2

فسيكون لونه أحمر وإلا سيكون مثل الباقي أخضر

تم تعديل سبتمبر 15, 2010 بواسطه TareQ M

[الخالدي]

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

اضافة الى حل اخي المهندس طارق

ولإثراء الموضوع

في المرفق يتم الانتقال الى السعر المختلف لنفس الصنف من خلال النقر بالماوس

يعيب الملف طول المعادلة المستخدمة.

تحياتي

إشكال في بيان التعبئة1.rar

[onlymanly]

يا أهلا بأهل الغوث و البركة... أسأل الله -إن كان لي من دعوة مستجابة- أن يجعل أيامكم كلها أعياد و أن يجعلكم بين الخلائق أعياناًو أسياد..

استاذي طارق : اشكرك شكر المتاج للعون فأعنته.. وشكر المستغيث فنجَّيته.. كفيت ووفيت ...

أستاذي الخالد: لك الشكر و الإمتنان حتى ترضى .. عودتنا على إيجاد الحلول بالمعادلات و إن كانت مستعصية ... بارك الله فيك و في علمك و زادك من واسع جوده

وفضله و إياي..

أتسائل : بالنسبة لأكواد الأستاذ طارق.. هل بالإمكان أن يتم جمع الكمية كاملة للصنف المكرر الملون باللون الأحمر أمام أول موضع تكرير له؟

الف الف شكر لكم جميعا..و كل عام و أنتم بالف خير

[طارق محمود]

السلام عليكم

أتسائل : بالنسبة للأكواد .. هل بالإمكان أن يتم جمع الكمية كاملة للصنف المكرر الملون باللون الأحمر أمام أول موضع تكرير له؟

نعم أخي يمكن ذلك

تفضل المرفق

onlyman-3.rar

[onlymanly]

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

[onlymanly]

استاذ طارق... قد كثرت عليك.. و أطمع في كرمك..

هل يمكن أن يعمل الكود فقط في الأصناف المكررة ؟؟ و يسكت عن الذي ليس مكررا ؟؟

[طارق محمود]

السلام عليكم ولايهمك ياأستاذ المهم المعلومة توصل لمن يحتاجها

تقول

هل يمكن أن يعمل الكود فقط في الأصناف المكررة ؟؟ و يسكت عن الذي ليس مكررا ؟؟

نعم طبعا

أضف للكود بعد سطر

On Error GoTo ErrHandler

السطور التالية

 If Range("J" & Target.Row).Value = 1 Then

 Range("A14:L64").Interior.Pattern = xlNone

 Exit Sub

 End If

أو إستبدل الكود كله بالتالي

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


Dim myrange, a, b As Range, rep(99) As Integer


 On Error GoTo ErrHandler

 If Range("J" & Target.Row).Value = 1 Then

 Range("A14:L64").Interior.Pattern = xlNone

 Exit Sub

 End If

 Application.EnableEvents = False

 rr = Target.Row

 x = [a1].Offset(rr - 1, 0)

 Set myrange = Range("A14:A64")

 Range("A14:L64").Interior.Pattern = xlNone

 i = 0

 Range("M14:M64").ClearContents

	For Each s In myrange

 	y = s.Value

 	If y = x Then

 	i = i + 1

 	Range("A" & s.Row, "L" & s.Row).Interior.ColorIndex = 4

 	rep(i) = s.Row

 	End If

	Next s


	sum_nj = 0: chg = 0

	For j = 1 To i

 	Set a = Range("H" & rep(j))



 	For nj = 1 To i

 	Set b = Range("H" & rep(nj))

 	If b.Value <> a.Value Then chg = 1: b.Interior.ColorIndex = 3

 	Next nj


	Next j



	If chg <> 0 Then

 	For j = 1 To i

 	sum_nj = sum_nj + Range("G" & rep(j)).Value

 	Next j

	End If

	If sum_nj <> 0 Then Range("M" & rep(1)).Value = sum_nj


ErrHandler:

 Application.EnableEvents = True

End Sub

تم تعديل سبتمبر 16, 2010 بواسطه TareQ M