(تمت الاجابة) استبدال معادلة بكود ان امكن

[بوعلام]

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

أنا أعمل على برنامج ولكن لتكرار المعادلات اصبح الملف ثقيلا

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

الغيابات برنامج.rar

[abouelhassan]

تفضل اخى من ابداع الاستاذ ابوتامر

احترامى

الغيابات برنامج.rar

[بوعلام]

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

شكرا على سرعة تجاوبك أخي

لكن المعادلات لازالت تظهر في الخانات

أرجوا الشرح

وشكرا

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

السلام عليكم

اخي الفاضل قم بمسح جميع معادلات الصفيف في الجدول

ثم ضع هذا الكود في زر امر

Sub Abu_Ahmed()

Dim cl As Range

Range("B8:D52").ClearContents

Set MyRng = Sheets("البيانات").Range("D8:D17")

Application.ScreenUpdating = False

For Each cl In MyRng

If cl.Value = [B6].Value Then

LR = Range("B" & Rows.Count).End(xlUp).Row + 1

Cells(LR, 2) = cl.Offset(0, -1)

Cells(LR, 3) = cl.Offset(0, 1)

Cells(LR, 4) = cl.Offset(0, 2)

End If

Next

End Sub

[بوعلام]

السلام عليكم

بارك الله فيك أخي أبو أحمد

هذا الكود تحفة حقا

جعل الله ما تقومون به في ميزان حسناتكم

إذاكانت لدي عدة أقسام في الورقة كيف يكون الكود يا ترى

وشكرا

[بوعلام]

للرفع

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

السلام عليكم

ضع مرفق

[بوعلام]

السلام عليكم

تفضل أخي أبو أحمد

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

الغيابات برنامج.rar

[abouelhassan]

كل الشكر والتقدير استاذنا عبدالله المجرب فوق الرائع

اخى

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

احترامى

[بوعلام]

كل الشكر والتقدير استاذنا عبدالله المجرب فوق الرائع

اخى

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

احترامى

السلام عليكم أخي

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

حاول ان ترسله لي مرة اخرى

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

السلام عليكم

اخي ابوعلام

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

Sub Abu_Ahmed()

Dim cl As Range

Range("B8:D52,B56:D100,B104:D148,B152:D196,B200:D244").ClearContents

Set MyRng = Sheets("البيانات").Range("D8:D1000")

Application.ScreenUpdating = False

For Each cl In MyRng

If cl.Value = [B6].Value Then

LR = Cells(52, 2).End(xlUp).Row + 1

Cells(LR, 2) = cl.Offset(0, -1)

Cells(LR, 3) = cl.Offset(0, 1)

Cells(LR, 4) = cl.Offset(0, 2)

End If

' =====

If cl.Value = [B54].Value Then

LR = Cells(100, 2).End(xlUp).Row + 1

Cells(LR, 2) = cl.Offset(0, -1)

Cells(LR, 3) = cl.Offset(0, 1)

Cells(LR, 4) = cl.Offset(0, 2)

End If

' =====

If cl.Value = [B102].Value Then

LR = Cells(148, 2).End(xlUp).Row + 1

Cells(LR, 2) = cl.Offset(0, -1)

Cells(LR, 3) = cl.Offset(0, 1)

Cells(LR, 4) = cl.Offset(0, 2)

End If

' =====

If cl.Value = [B150].Value Then

LR = Cells(196, 2).End(xlUp).Row + 1

Cells(LR, 2) = cl.Offset(0, -1)

Cells(LR, 3) = cl.Offset(0, 1)

Cells(LR, 4) = cl.Offset(0, 2)

End If

' =====

If cl.Value = [B198].Value Then

LR = Cells(244, 2).End(xlUp).Row + 1

Cells(LR, 2) = cl.Offset(0, -1)

Cells(LR, 3) = cl.Offset(0, 1)

Cells(LR, 4) = cl.Offset(0, 2)

End If

'=====

Next

End Sub

[بوعلام]

السلام عليكم

ما شاء الله عليك أخي أبو أحمد كود أكثر من رائع كما عودتنا دائما

بارك الله فيك وجزاك الله كل خير

شكرا جزيلا