اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

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

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

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

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

  • Like 1
رابط هذا التعليق
شارك

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

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

حفظكم الله ..

رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

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

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

اليك الكود :

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

 

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information