(تمت الاجابة) بالكود مسح قيمة خلية بناءاً على شرط

[أبو أنس حاجب]

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

المطلوب حفظكم الله كود يقوم بمسح علامة أكس من الخلية المجاورة للعمود H اذا تحقق شرط أن الاسم الموجود في العمود H موجود أيضاً في العمود J طبعاً الأسماء في العمود J متغيرة وليست ثابته

والله الموفق والمستعان

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

أبو أنس

مسح قيمة خلية بناءاً على شرط.rar

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

جرب هذا الكود

Sub Abu_Ahmed_Delet()

Dim CL As Range

For Each CL In [H4:H1000]

If Application.CountIf([J4:J1000], CL) = 1 Then CL.Offset(0, 1) = Empty

Next

End Sub

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل عبد الله المجرب (أبا أحمد) حفظك الله وأكرم منزلك في الجنة

أشكرك على السرعة والكفاءة والاحتراف في الرد جزاك الله خير الجزاء في الدنيا وحسن ثواب الآخرة.

ملاحظة بسيطة لو لاحظت أن لدي معادلات صفيف في العمود M مما سببت بطئ شديد لعمل الكود هل من حل؟

أبو أنس

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل أبا أحمد حفظك الله

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

Sub Abu_Ahmed_Delet()

[M3:M1000].ClearContents

Dim CL As Range

For Each CL In [H4:H1000]

If Application.CountIf([J4:J1000], CL) = 1 Then CL.Offset(0, 1) = Empty

Next

[M2].Copy

[M3:M1000].PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

End Sub

هنالك رجاء آخر هل ممكن عمل كود عكسي للموضوع بحيث أذا كانت خلايا العمود I كلها فارغة يقوم بإضافة علامة أكس في الخلايا التي لايوجد فيها تناظر للاسماء بين العمودين J و K

أرجو أن لا أكون أخذت من وقتك أكثر مما أستحق ربما غيري أحوج مني لوقتك

أبو أنس

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

ما رايك ان تجرب وضع

Application.Calculation = xlManual

في بداية الكود و

Application.Calculation = xlAutomatic

في نهايته

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل عبد الله المجرب (أبا أحمد) حفظك الله

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

هنالك رجاء آخر هل ممكن عمل كود عكسي للموضوع بحيث أذا كانت خلايا العمود I كلها فارغة يقوم بإضافة علامة أكس في الخلايا التي لايوجد فيها تناظر للاسماء بين العمودين J و K

أبو أنس

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل عبد الله المجرب (أبا أحمد) حفظك الله

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

هنالك رجاء آخر هل ممكن عمل كود عكسي للموضوع بحيث أذا كانت خلايا العمود I كلها فارغة يقوم بإضافة علامة أكس في الخلايا التي لايوجد فيها تناظر للاسماء بين العمودين J و K

أبو أنس

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

سيصبح الكود هكذا

Sub Abu_Ahmed_Delet()

Dim CL As Range

For Each CL In [H4:H1000]

If Application.CountIf([J4:J1000], CL) = 0 Then CL.Offset(0, 1) = "X"

Next

End Sub

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل عبد الله المجرب حفظك الله

جزاك الله خير الجزاء على أهتمامك الدائم وعلى ما تقدمه في هذا الصرح.

بالنسبة للكود فهو سليم عدا انه ايضاً يضيف حرف الــ X أيضاً مقابل الخلايا الفارغة في العمود H

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

أرجو أفادتي بصحتها وهل يمكن أختزالها في الكود.

LR = Cells(Rows.Count, 8).End(xlUp).Row + 0

Application.ScreenUpdating = False

Range("i" & LR + 1 & ":i" & Rows.Count).ClearContents

Application.ScreenUpdating = True

أبو أنس

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل عبد الله المجرب حفظك الله

جزاك الله خير الجزاء على أهتمامك الدائم وعلى ما تقدمه في هذا الصرح.

بالنسبة للكود فهو سليم عدا انه ايضاً يضيف حرف الــ X أيضاً مقابل الخلايا الفارغة في العمود H

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

أرجو أفادتي بصحتها وهل يمكن أختزالها في الكود.

LR = Cells(Rows.Count, 8).End(xlUp).Row + 0

Application.ScreenUpdating = False

Range("i" & LR + 1 & ":i" & Rows.Count).ClearContents

Application.ScreenUpdating = True

أبو أنس

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل عبد الله المجرب حفظك الله

جزاك الله خير الجزاء على أهتمامك الدائم وعلى ما تقدمه في هذا الصرح.

بالنسبة للكود فهو سليم عدا انه ايضاً يضيف حرف الــ X أيضاً مقابل الخلايا الفارغة في العمود H

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

أرجو أفادتي بصحتها وهل يمكن أختزالها في الكود.

LR = Cells(Rows.Count, 8).End(xlUp).Row + 0

Application.ScreenUpdating = False

Range("i" & LR + 1 & ":i" & Rows.Count).ClearContents

Application.ScreenUpdating = True

أبو أنس

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

جرب هذا التعديل

Sub Abu_Ahmed_Delet()

Dim CL As Range

For Each CL In [H4:H1000]

If Not IsEmpty(CL) And Application.CountIf([J4:J1000], CL) = 0 Then CL.Offset(0, 1) = "X"

Next

End Sub

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل عبد الله المجرب (أبا أحمد) حفظك الله

ما شاء الله تبارك الله في المختصر ا لمفيد بارك الله فيك وبك وأجزل لك العطاء حتى ترضى.

أبو أنس