مطلوب كود تحديد الخلايا في عمود ابتداءً بخلية معينة

[Abdualmalek]

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

لدي هذا الكود الذي يقوم بتحديد الخلايا التي بها كتابة دون الخلايا الفارغة في عمود ما. 

ActiveSheet.Colums ("J:J").specialCells (xlCellTypeConstants, 23).select

 لكن المشكلة انه يبدأ التحديد من بداية العمود، هل من الممكن التعديل عليه بحيت يبدأ متلا من الخلية j5 وحتى اخر خلية بها كتابة بالعمود

وهل يوجد كود يقوم بتحديد الخلايا التي بها ارقام فقط دون الخلايا الفارغة او التي بها كلمات

وشكرا

تم تعديل يوليو 20, 2019 بواسطه Abdualmalek

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

حيث انك لم ترفع ملفاً للمعاينة

قمت بتصميم ملف يتناول ما تريد (مع حرية اختيار البداية وانهاية)

Option Explicit
Sub select_my_special_range()
Dim z%, y#, x#, i#
Dim Lr%: Lr = Cells(Rows.Count, "F").End(3).Row
Dim My_min#: My_min = Application.Min([b2:c2])
Dim My_max#: My_max = Application.Max([b2:c2])

If My_max > Lr Then _
My_max = Lr: [c2] = My_max
If My_min > Lr Then _
My_min = 1: [c2] = My_min
Dim my_rg As Range
 Range("f1:f" & Lr).Interior.ColorIndex = xlNone
  i = My_min
 Do While i < My_max + 1
 On Error Resume Next
 x = 1 / Range("f" & i)
 y = Range("f" & i) + 1
 z = IsEmpty(Range("f" & i))
 On Error GoTo 0
  If x + y + z <> 0 Then
   If my_rg Is Nothing Then
    Set my_rg = Range("f" & i)
     Else
     Set my_rg = Union(my_rg, Range("f" & i))
      End If
   End If
 i = i + 1
x = 0: y = 0
 Loop
 my_rg.Select
 my_rg.Interior.ColorIndex = 6
 MsgBox "YOUR RANGE IS :" & Chr(10) & my_rg.Address

End Sub

  الملف مرفق

 

select_numeric.xlsm

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

تحديث بسيط على الكود و فعاليته

Option Explicit
Sub select_my_special_range()
Dim z%, y#, x#, i#
Dim Lr%: Lr = Cells(Rows.Count, "F").End(3).Row
Dim My_min#: My_min = Application.Min([b2:c2])
Dim My_max#: My_max = Application.Max([b2:c2])
[c2] = My_max: [b2] = My_min
If My_max > Lr Then _
My_max = Lr: [c2] = My_max
If My_min > Lr Then _
My_min = 1: [b2] = My_min
Dim my_rg As Range
 Range("f1:f" & Lr).Interior.ColorIndex = xlNone
  i = My_min
 Do While i < My_max + 1
 On Error Resume Next
 x = 1 / Range("f" & i)
 y = Range("f" & i) + 1
 z = IsEmpty(Range("f" & i))
 On Error GoTo 0
  If x + y + z <> 0 Then
   If my_rg Is Nothing Then
    Set my_rg = Range("f" & i)
     Else
     Set my_rg = Union(my_rg, Range("f" & i))
      End If
   End If
 i = i + 1
x = 0: y = 0
 Loop
 my_rg.Select
 my_rg.Interior.ColorIndex = 6
 MsgBox "YOUR RANGE IS :" & Chr(10) & _
 Join(Split(my_rg.Address, ","), Chr(10))

End Sub

الملف من جديد

 

select_numeric_new.xlsm

[Abdualmalek]

فعلا لم ارفق الملف ظنا مني انه سيكون تعديل بسيط على الكود لكن جزاك الله خيرا قمت ببرمجة كود ممتاز يقوم بالمطلوب واكتر 

بارك الله فيك

 

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

انظر الى المشاركة الاخيرة 

هناك تفاصيل اكثر حيث يقوم الكود بوضع كل نطاق من الــ  Range في سطر مستقل داخل الــــ  MsgBox لحسن قرائته

[Abdualmalek]

نعم قمت بتحميله، سلمت يداك وزادك الله من علمه اخي 

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

بقي عليك ان تضغط رز أفضل اجابة(على المشاركة الاخيرة) لاغلاق الموضوع