معادلة لعد اسماء كل صفحة حسب حدود الصفحة + جمع مبالغ كل صفحة

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

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

سبق مشكور الاستاذ سليم وصمم كود

ولكن محتاج معادلة لاضافة فقرات جديدة - وكما موضح بالشيت 

ارجو من حضراتكم الاهتمام بالموضوع لحاجتي للمعادلة لتسهيل العمل وسرعة الانجاز والدقة

 

 

معادلة لعد اسماء كل صفحة مع الجمع.xlsm

تم تعديل يوليو 2, 2019 بواسطه خالد ابوعوف

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

من الصعب جداً تشغيل معادلات لمثل هذه الــ DATA

لكن بواسطة الــ VBA  يمكن عمل أي شيء

الملف المرفق ديناميكي تستطيع ان تضع قدر ما تشاء من الأقسام والقوائم

الكود

Option Explicit
Sub Salim_Has()
Dim my_rg As Range
Dim Main As Worksheet
Set Main = Sheets("الخلاصة")
Main.Cells.ClearContents
Dim i%, x%: x = 1
Main.Rows("1:2").ClearContents
Dim const_arr(1 To 3)
const_arr(1) = "رقم القائمة": const_arr(2) = "عدد أسماء القائمة"
const_arr(3) = "مبلغ القائمة"
Dim arr_sh(1 To 3)
 For i = 1 To Sheets.Count - 1
 arr_sh(i) = Sheets(i + 1).Name
Next
 For i = 1 To UBound(arr_sh)
  Main.Cells(1, x) = arr_sh(i)
  Main.Cells(2, x).Resize(, 3) = const_arr
  x = x + 4
Next
get_data
End Sub
Rem ==========================
Rem form here start a new Macro
Rem=========================
Sub get_data()
Dim Prince_sh As Worksheet
Set Prince_sh = Sheets("الخلاصة")
Dim last_col%, my_st$: my_st$ = "قائمة رقم "
Dim i%, last_row%, m%: m = 4
Dim k%, XX%, t%: t = 1
Dim target_sh As Worksheet
Dim temp As Range
last_col = Prince_sh.Cells(1, Columns.Count).End(1).Column
For i = 1 To last_col Step 4
Set target_sh = Sheets(Prince_sh.Cells(1, i) & "")
 last_row = target_sh.Cells(Rows.Count, 1).End(3).Row
  For k = 2 To last_row
   If target_sh.Cells(k, 2) <> "الاسم" And target_sh.Cells(k, 2) <> vbNullString Then
    If temp Is Nothing Then
     Set temp = target_sh.Cells(k, 2)
     Else
     Set temp = Union(target_sh.Cells(k, 2), temp)
     End If
      End If
    Next
    If temp Is Nothing Then GoTo My_Next
    For XX = temp.Areas.Count To 1 Step -1
     Prince_sh.Cells(m, i) = my_st$ & t
     Prince_sh.Cells(m, i + 1) = Application.CountA(temp.Areas(XX))
     Prince_sh.Cells(m, i + 2) = Application.Sum(temp.Areas(XX).Offset(, 1))
     m = m + 1: t = t + 1
    Next
My_Next:
    Set temp = Nothing: m = 4: t = 1
 Next
End Sub

الملف مرفق

 

 

Full_File.xlsm

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

الله يبارك فيك - جزيت خيرا

في ميزان حسناتك 

تمام 100 %

سؤال : اذا تغيير عندي عمود (مبلغ القائمة) في شيت قسم1 وقسم2 وقسم3 

واصبح في خلية (K) أي أصبح في عمود (11) 

اين السطر المسؤول عن هذه الفقرة في الكود

لأنه حاولت ما نجحت معاي

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

23 دقائق مضت, خالد ابوعوف said:

الله يبارك فيك - جزيت خيرا

في ميزان حسناتك 

تمام 100 %

سؤال : اذا تغيير عندي عمود (مبلغ القائمة) في شيت قسم1 وقسم2 وقسم3 

واصبح في خلية (K) أي أصبح في عمود (11) 

اين السطر المسؤول عن هذه الفقرة في الكود

لأنه حاولت ما نجحت معاي

من العامود B  الى العامود  K هناك 10 أعمدة (تنقص منها 1 ) فتصبح 9

في هذا السطر من الكود 

Prince_sh.Cells(m, i + 2) = Application.Sum(temp.Areas(XX).Offset(, 1))

تستبدل الرقم 1 بالرقم 9

ليصبح بهذا الشكل

Prince_sh.Cells(m, i + 2) = Application.Sum(temp.Areas(XX).Offset(, 9))

 

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

تمت العملية بنجاح

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

اذا سمحت - اخ سليم - اذا تم تسمية شيتات جديد باسماء مختلفة 

ممكن تحديد الشيتات المراد عمل الكود عليها اذا تم فتح شيت جديد - وبالتالي توقف الكود عن العمل

 

 

تم تعديل يوليو 2, 2019 بواسطه خالد ابوعوف

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

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

تمت العملية بنجاح

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

اذا سمحت - اخ سليم - اذا تم تسمية شيتات جديد باسماء مختلفة 

ممكن تحديد الشيتات المراد عمل الكود عليها اذا تم فتح شيت جديد - وبالتالي توقف الكود عن العمل

 

 

الكود لا يتأئر باسماء الشيتات لأنه يدرجها اوتوماتيكياً في الصف الأول

فقط يجب ان تكون الصفحة  "خلاصة "هي الأولى

واذا وجدت شيت لا تحتوي على بيانات(في الأعمدة 1و2و3) يتم تجاهلها

مهم جداً وجود كلمة "الاسم" في العامود الثاني من كل شيت

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

السلام عليكم

ارفق ملف يحتوي على شيت جديد اسمه المخصصات (شيت ليس له علاقة بالاقسام)

وعند تنفيذ الكود - يذهب الى محرر الاكواد لوجود مشكلة بالشيت المضاف الجديد (المخصصات)

عد القوائم والمبلغ - استاذ سليم-3.xlsm

تم تعديل يوليو 2, 2019 بواسطه خالد ابوعوف

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

تم معالجة الموضوع

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

كذلك الشيت المخصصات لا تحتوي على كلمة الاسم في العامود B فتجاهلها الكود

امام الشيت laste_sheet فتم ادراجها

Option Explicit
Sub Salim_Has()
Dim my_rg As Range
Dim Main As Worksheet
Dim Cont%: Cont = Sheets.Count
If Cont = 1 Then Exit Sub
Set Main = Sheets("الخلاصة")
On Error Resume Next
Main.Cells.ClearContents
On Error GoTo 0
Dim NUM%: NUM = 1
Dim i%, x%: x = 1
Dim arr_sh()
Dim const_arr(1 To 3)
const_arr(1) = "رقم القائمة": const_arr(2) = "عدد أسماء القائمة"
const_arr(3) = "مبلغ القائمة"

     For i = 1 To Cont
      If Sheets(i).Name = "الخلاصة" Then _
        GoTo NexT_i
      If IsError(Application.Match("الاسم", Sheets(i).Range("B:B"), 0)) _
        Then GoTo NexT_i
      ReDim Preserve arr_sh(1 To NUM)
      arr_sh(NUM) = Sheets(i).Name
       NUM = NUM + 1
    
NexT_i:
      Next
        For i = 1 To UBound(arr_sh)
            Main.Cells(1, x) = arr_sh(i)
            Main.Cells(2, x).Resize(, 3) = const_arr
            x = x + 4
        Next
get_data
Erase arr_sh: Erase const_arr
End Sub
Rem ==========================
Rem form here start a new Macro
Rem=========================
Sub get_data()
Dim Prince_sh As Worksheet
Set Prince_sh = Sheets("الخلاصة")
Dim last_col%, my_st$: my_st$ = "قائمة رقم "
Dim i%, last_row%, m%: m = 4
Dim k%, XX%, t%: t = 1
Dim target_sh As Worksheet
Dim temp As Range
last_col = Prince_sh.Cells(1, Columns.Count).End(1).Column
For i = 1 To last_col Step 4
  Set target_sh = Sheets(Prince_sh.Cells(1, i) & "")
  last_row = target_sh.Cells(Rows.Count, 1).End(3).Row
For k = 2 To last_row
   If target_sh.Cells(k, 2) <> "الاسم" And target_sh.Cells(k, 2) <> vbNullString Then
        If temp Is Nothing Then
            Set temp = target_sh.Cells(k, 2)
        Else
            Set temp = Union(target_sh.Cells(k, 2), temp)
        End If
   End If
 Next
    If temp Is Nothing Then GoTo My_Next
    For XX = temp.Areas.Count To 1 Step -1
        Prince_sh.Cells(m, i) = my_st$ & t
        Prince_sh.Cells(m, i + 1) = Application.CountA(temp.Areas(XX))
        Prince_sh.Cells(m, i + 2) = Application.Sum(temp.Areas(XX).Offset(, 9))
        m = m + 1: t = t + 1
    Next
My_Next:
    Set temp = Nothing: m = 4: t = 1
 Next
End Sub

 

 

My_Last_File.xlsm

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

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

اشكرك - الحمد لله تم المطلوب - جزاك الله على جهودك