كيفيه تخطى الداله الخليه

[ايهاب السيد بدوى]

بسم الله الرحمن الرحيم

اذا اردت ان اسحب الداله فى العمود B:Bنزولا الى الاسفل مع تخطى الخليه الصفراء وجعلها غير خاضعه للداله والخلايا التى اسفل الخليه الصفراء تكون خاضعه للداله ماذا افعل ؟

المصنف1.rar

[سليم حاصبيا]

جرب هذا الملف

 

 

المصنف1 salim.zip

تم تعديل ديسمبر 4, 2015 بواسطه سليم حاصبيا

[مختار حسين محمود]

أخى سليم حل رائع

بعد اذنك فى التعديل البسيط

(  تعريف المتعير LR و X و تمييز الخلية المستثناه من داخل الكود ليصبخ الكود مرناً ويمكن جعله أكثر مرونة بجعل المستخدم يختار الخلية وهو ما لم أذكره)

Sub yellow_cell2()
 Dim LR As Long, X As Integer
 LR = Cells(Rows.Count, 1).End(3).Row
 
 With Range("B2:B" & LR)
    .ClearContents
    .Interior.Pattern = xlNone
 End With
 
 Range("B4").Interior.ColorIndex = 6   ' حدد الخلية المراد تخطيها هنا
 For X = 2 To LR
     If Cells(X, 2).Interior.ColorIndex <> 6 Then
        Cells(X, 2).Formula = "=ROUNDDOWN((RC[-1]*15%),2)"
     End If
 Next
 Range("B2:B" & LR).Value = Range("B2:B" & LR).Value
End Sub

الأخ ايهاب طبق الكود على النطاق مباشرة لا تلون أى خلايا يدويا فقط حدد الخلايا المراد تخطيها فى الكود   تحياتى  للجميع

 

تم تعديل ديسمبر 4, 2015 بواسطه مختار حسين محمود

[سليم حاصبيا]

ممتاز اخي مختار

ولكن لما الارتباط بقيمة 15% 

دع المستخدم يختار القيمة من الخلية B1 

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

 

[مختار حسين محمود]

  حسب ما فهمت  تريد أن يختار  المستخدم    القيمة من الخلية B1 

 يمكن للمستخدم  أن يختار  القيمة من الخلية B1  أو أى خلية أخرى بها نسبة مئوية  حسب الكود التالى :

Sub yellow_cell3()
 Dim LR As Long, X As Integer, S
 LR = Cells(Rows.Count, 1).End(3).Row
 
 With Range("B2:B" & LR)
    .ClearContents
    .Interior.Pattern = xlNone
 End With
 
 Range("B4").Interior.ColorIndex = 6   ' حدد الخلية المراد تخطيها هنا
 Set S = Application.InputBox("حدد الخلية التى تريد الحساب على أساسها :", Title:="حساب النسبة المئوية", Type:=8)
 Application.ScreenUpdating = False
 Range("XFD1") = S
 For X = 2 To LR
     If Cells(X, 2).Interior.ColorIndex <> 6 Then
        Cells(X, 2).Formula = "=ROUNDDOWN((RC[-1]*INDIRECT(""XFD1"")),2)"
     End If
 Next
 Range("B2:B" & LR).Value = Range("B2:B" & LR).Value
 Application.ScreenUpdating = True
End Sub