نسخ أخر قيم فى نطاقات متعدده

[samycalls2020]

السلام عليكم

الرجاء المساعده فى كود لنسخ أخر قيم فى نطاقات متعدده الى خلايا معينة كما فى المرفق .. 

نسخ أخر قيم فى نطاقات متعدده.xlsm

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

Try This File

Last_Cell.xlsm

[ابراهيم الحداد]

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

لمعرقة النطاقات الخالية و تحقيق المطلوب فى نفس الوقت

اعتقد من الافضل استخدام الكود التالى

Sub LastValue()
Dim i As Integer, j As Integer
Dim x As Integer, y As Integer
Range("G9:J9").ClearContents
x = 7
i = 7
j = 13
Do While i <= 28
Do While j <= 34
y = WorksheetFunction.Max(Range(Cells(i, 3), Cells(j, 3)))
If y > 0 Then
Cells(9, x).Value = y
Else
Cells(9, x).Value = 0
End If
x = x + 1
i = i + 7
j = j + 7
Loop
Loop
End Sub

 

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

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

Option Explicit
Sub get_col_1()
Dim arr(), My_val, K%, Rg As Range
Dim Ro%, m%, i%
Ro = Cells(Rows.Count, 3).End(3).Row
arr = Array(6, 44, 37, 40)
Range("F7").Resize(, Ro).Clear
m = 6
For i = LBound(arr) To UBound(arr)
    My_val = vbNullString
     For K = 7 To Ro
      If Cells(K, 3).Interior.ColorIndex = arr(i) _
      And Cells(K, 3) <> vbNullString Then
      My_val = Cells(K, 3)
      End If
     Next K
     With Cells(7, m)
      .Value = My_val
      .Interior.ColorIndex = arr(i)
     End With
    m = m + 1
Next i
End Sub

الملف مرفق

Last_Cell_ALL.xlsm

[samycalls2020]

أحمد الله أن حبانا المولى عز وجل بهذه القامات الكبيرة

كل الشكر للأساتذة العظام .. سأقوم بتطبيق الأكوداد على الملف الأصلى للوصول الى الكود الأنسب

حفظكم الله ..

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

كي يعمل الكود الذي وضعته لك في المشاركة الثانية

يجب وضع نفس الالوان كما في الملف الذي رفعنه لك في المشاركة الثانية (Last_Cell_ALL) أو تغيير الـــ Array الى نفس الالوان التي عندك في الملف

[samycalls2020]

استاذ / سليم ..

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

فكيف الاستغناء عنها فى الكود .. 

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

اذن كيف تميز اين يبدأ اي نطاق و اين ينتهي

و هل صفوف كل نطاق ثابتة ام متغيرة؟؟

[samycalls2020]

النطاقات هى C7 :C96 , 97:C186  ,  C187:C306 , C307:C396 , C397:C486 , C487:C576 , C577:C666 , C667:C756 , C757:C846 , C847:936 , C937:C1026

وهى نطاقات ثابته

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

تم التعديل على الماكرو ليعمل كما تريد

Option Explicit

Sub get_value()
          Rem Created by salim Hasbaya On 10/3/2020
  Dim dic As Object, i%, ky, t, cel As Range
  Dim rg As Range, m%, My_val
If ActiveSheet.Name <> "Salim" Then GoTo Exit_Me
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
Range("F7").CurrentRegion.Clear
Range("C7:C1000").Interior.ColorIndex = xlNone
m = 6
For i = 7 To 937 Step 90
 dic(i) = vbNullString
 Next
 For Each ky In dic.keys
  Set rg = Cells(ky, 3).Resize(90)
  Set rg = rg.SpecialCells(2)
  For Each cel In rg
     t = cel.Address(0, 0)
     My_val = cel.Value
  Next
   Cells(6, m) = t
   Cells(7, m) = My_val
    
   Range(t).Interior.ColorIndex = 6
   m = m + 1
   Next
   With Range("F7").CurrentRegion
    .Interior.ColorIndex = 6
    .Borders.LineStyle = 1
    .Font.Bold = True
    .Font.Size = 14
    .HorizontalAlignment = 2
    .InsertIndent 1
  End With
Exit_Me:
  Application.ScreenUpdating = True
   Set dic = Nothing: Set cel = Nothing
   Set rg = Nothing
End Sub

الملف مرفق

My_Last_Cells.xlsm

[ابراهيم الحداد]

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

اخى اقصى ما استطعت الوصول اليه

هو  جلب القيم المطلوبة دون التقيد باى نطاق و لكن  عيبه الوحيد 

ان الكود التالى سوف يتجاهل النطاقات الخالية تماما

و لا اعلم ان كان سيروق لك هذا ام لا

اليك الكود :

Sub LastValues()
Dim C As Range, i As Long, x As Integer
For Each C In Range("C7:C100")
If IsEmpty(C) Then
i = C.Row - 1
x = Cells(i, 3)
If x > 0 Then
p = p + 1
Cells(7, p + 12) = x
End If
End If
Next
End Sub

 

[samycalls2020]

الشكر كل الشكر للأخوة الكرام