عد الخلايا في القائمة على اساس حدود الصفحة + مبلغ القائمة

[خالد ابوعوف]

السلام عليكم - حياكم الله

معادلة لعد خلايا كل قائمة على اساس حدود الصفحة

+ مبلغ كل قائمة

 

عد القوائم.xlsx

تم تعديل يوليو 1, 2019 بواسطه خالد ابوعوف
اضافة فقرة مبلغ القائمة

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

ربما ينفع هذا الكود

Sub Salim_Has()
Dim my_rg As Range
Dim i%, last_row%, m%: m = 2
Dim my_st$
my_st$ = "قائمة رقم "
last_row = Quawaem.Cells(Rows.Count, 1).End(3).Row

Khoulasa.Range("a1").CurrentRegion. _
Offset(1).ClearContents
For i = 3 To last_row
If Quawaem.Range("b" & i) <> "" And _
 Quawaem.Range("b" & i) <> "الاسم" Then
 If my_rg Is Nothing Then
    Set my_rg = Quawaem.Range("B" & i)
  Else
   Set my_rg = Union(Quawaem.Range("B" & i), my_rg)
 End If
End If

 Next
For i = my_rg.Areas.Count To 1 Step -1
    Khoulasa.Cells(m, 2) = _
    Application.CountA(my_rg.Areas(i))
    Khoulasa.Cells(m, 1) = my_st$ & m - 1
    m = m + 1
Next

Set my_rg = Nothing
End Sub

الملف مرفق

Quawaem_count_new.xlsm

[خالد ابوعوف]

حياك الله - استاذ

تسلم - جزيت خيرا

ممكن النظر مشكور  الى الملف  - تم اضافة - فقرة - جمع كل قائمة

أم اجعله في طلب مستقل

جزيتم خيرا

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

2 ساعات مضت, خالد ابوعوف said:

حياك الله - استاذ

تسلم - جزيت خيرا

ممكن النظر مشكور  الى الملف  - تم اضافة - فقرة - جمع كل قائمة

أم اجعله في طلب مستقل

جزيتم خيرا

تعديل  على الكود ليتناسب مح المطلوب

 

Option Explicit
Sub Salim_Has()
Dim my_rg As Range
Dim i%, last_row%, m%: m = 2
Dim my_st$
my_st$ = "قائمة رقم "
last_row = Quawaem.Cells(Rows.Count, 1).End(3).Row

Khoulasa.Range("a1").CurrentRegion. _
Offset(1).ClearContents
For i = 3 To last_row
If Quawaem.Range("b" & i) <> "" And _
 Quawaem.Range("b" & i) <> "الاسم" Then
 If my_rg Is Nothing Then
    Set my_rg = Quawaem.Range("B" & i)
  Else
   Set my_rg = Union(Quawaem.Range("B" & i), my_rg)
 End If
End If

 Next
For i = my_rg.Areas.Count To 1 Step -1
 With Khoulasa.Cells(m, 1)
   .Value = my_st$ & m - 1
   .Offset(, 1) = Application.CountA(my_rg.Areas(i))
   .Offset(, 2) = Application.Sum(my_rg.Areas(i).Offset(, 1))
 End With
    m = m + 1
Next
Set my_rg = Nothing
End Sub

الملف من جديد

 

Quawaem_count_new.xlsm

[خالد ابوعوف]

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

الكود - جزيت خير يفي بالغرض 100 % 

ممكن معادلات - احتاجه اذا عندي اكثر من شيت يحتوي على قوائم 

فاحتاج المعادلات لسهولة التغيير اسم الشيت - وتاتي القوائم مختلفة الاعمدة

شاكر جهودك وجزيت خيرا كثيراً - ورب كريم