تحديد خلايا متجاورة في أسطر غير متجاورة

[نايف - م]

ملف مرفق

أريد تحديد خلايا بأسطر غير متجاورة اذا كان لها رقم موجود بالعمود A يساوي رقم في خلية مفنرضة

المصنف1.rar

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

عليك بهذا الملف

 

المصنف1 cond.zip

[نايف - م]

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

أخي الكريم

طلبي تحديد select  و ليس تلوين بتنسيق شرطي

أريد ذلك عن طرق البرمجة في محرر الأكواد

لأني سأربط البرمجة بزر أمر

و شكرا لك

 

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

48 دقائق مضت, نايف - م said:

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

أخي الكريم

طلبي تحديد select  و ليس تلوين بتنسيق شرطي

أريد ذلك عن طرق البرمجة في محرر الأكواد

لأني سأربط البرمجة بزر أمر

و شكرا لك

 

تم التعديل حسب الطلب

 

المصنف1 cond.zip

[الـعيدروس]

بالامكان بهذا الشكل

  انسخ الكود والصقه في حدث الورقة

Private Const Ad_r As String = "$A$1" '' خلية شرط تطابق القيمة
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Row > 1 Then
With Target
      If .Value = Val(Range(Ad_r)) Then
          .Resize(1, 5).Interior.ColorIndex = 6
         Else
          .Resize(1, 5).Interior.Pattern = xlNone
      End If
End With
End If
End Sub

 

[نايف - م]

الأخ الفاضل سليم

بارك الله بهاتين اليدين المبدعتين

شكرا لك

هو المطلوب

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

 

[نايف - م]

سؤال للأخ سليم

عندما أردت أن أحول كل الصيغ في المجا ل (MY_RG)  لقيم أضفت سطر فأعطى نتيجة غير صحيحة

Dim lr As Integer
    Dim my_rg As Range
    Dim my_nb As Integer
    Dim i As Integer

 my_nb = Cells(1, 1).Value
lr = Cells(Rows.Count, 1).End(3).Row
 For i = 2 To lr
   If Cells(i, 1) = my_nb Then
        If my_rg Is Nothing Then
         Set my_rg = Cells(i, 1).Resize(1, 5)
            my_rg.Select
            Else
         Set my_rg = Union(my_rg, Cells(i, 1).Resize(1, 5))
            my_rg.Select
        End If
     End If
     Next
     my_rg.Select
     my_rg.Value = my_rg.Value

ممكن المساعدة في أكتشاف الخطأ أو أضافة السطر الصحيح

.شكرا

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

32 دقائق مضت, نايف - م said:

سؤال للأخ سليم

عندما أردت أن أحول كل الصيغ في المجا ل (MY_RG)  لقيم أضفت سطر فأعطى نتيجة غير صحيحة

Dim lr As Integer
    Dim my_rg As Range
    Dim my_nb As Integer
    Dim i As Integer

 my_nb = Cells(1, 1).Value
lr = Cells(Rows.Count, 1).End(3).Row
 For i = 2 To lr
   If Cells(i, 1) = my_nb Then
        If my_rg Is Nothing Then
         Set my_rg = Cells(i, 1).Resize(1, 5)
            my_rg.Select
            Else
         Set my_rg = Union(my_rg, Cells(i, 1).Resize(1, 5))
            my_rg.Select
        End If
     End If
     Next
     my_rg.Select
     my_rg.Value = my_rg.Value

ممكن المساعدة في أكتشاف الخطأ أو أضافة السطر الصحيح

.شكرا

انا مش عارف الفائدة من اخر سطر 

ماذا تقصد ان تفعل

[نايف - م]

الأخ سليم

ممكن أن توجد بعض الخلايا في هذا المجال و هي تحوي صيغ

أريد أن أحول الصيغ لقيمها في هذا المجال

إن أمكن

و شكرا

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

30 دقائق مضت, نايف - م said:

الأخ سليم

ممكن أن توجد بعض الخلايا في هذا المجال و هي تحوي صيغ

أريد أن أحول الصيغ لقيمها في هذا المجال

إن أمكن

و شكرا

استعمل هذا الكود لهذا الامر

Sub select_choosen_rows()
    Dim lr As Integer
    Dim my_rg As Range
    Dim my_nb As Integer
    Dim i As Integer
    Dim cel As Range

 my_nb = Cells(1, 1).Value
lr = Cells(Rows.Count, 1).End(3).Row
 For i = 2 To lr
   If Cells(i, 1) = my_nb Then
        If my_rg Is Nothing Then
         Set my_rg = Cells(i, 1).Resize(1, 5)

            Else
         Set my_rg = Union(my_rg, Cells(i, 1).Resize(1, 5))

        End If
     End If
     Next

     For Each cel In my_rg
     If cel.HasFormula Then cel.Value = cel.Value
     Next
End Sub

 

[نايف - م]

تمام هو المطلوب

شكرا لك و أدام لك الله هذه الموهبة

[نايف - م]

سؤال أحر مرتبط بنغس الفكرة

هل يمكن تحديد الخلايا في العمود    E  (فقط ) اذا كان قيمة الخلية في العمود a تساوي القيمة في الخلية   a1

 

[ياسر خليل أبو البراء]

أخي الكريم نايف

يرجى توضيح الفكرة المطلوبة بشكل أكثر تفصيلاً .. والأفضل لو بملف مرفق

[نايف - م]

الملف مرفق بالمشاركة الاولى استاذي الكريم

[ياسر خليل أبو البراء]

أخي الكريم نايف

أعتذر لأنني لم أتابع الموضوع منذ البداية وظننت أن هذا طلب مختلف

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

 

Sub Test()
    Dim MyRange As Range, Cel As Range, Rng As Range, LastCol As Long
    
    Set MyRange = Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
    
    For Each Cel In MyRange
        If Cel.Value = Range("A1").Value Then
            If Not Cel Is Nothing Then If Rng Is Nothing Then Set Rng = Cel Else Set Rng = Union(Rng, Cel)
        End If
    Next Cel
    
    Rng.Offset(, 4).Interior.ColorIndex = 6
End Sub

 

 

[نايف - م]

شكرا يا استاذي الكريم

هو المطلوب

 

[ياسر خليل أبو البراء]

عفواً أخي الكريم نايف

المهم أن تم المطلوب على خير .. وإلى لقاء في موضوع آخر

تقبل تحياتي