تجميع عدد من الجداول فى جدول

[yara ahmed]

مثال للمطلوب تجميع الجداول الى هذا الجدول ليكون رقم واحد لكل اسم موجود فى العمود A وممكن ان يزيد عدد الجداول
في الصفحات كل صفحة بها جدول
العمود A يحتوى على أسماء المطلوب تجميع الأسماء المتطابقة
واستخراج total
اما لو الاسم غير متطابق بردو يستدعى الى هنا وتحته المجموع الخاص به
حيث ان هذا الجدول هو تجميع للجداول بصفحات المصنف واستخراج جدول واحد به
مجموع كل اسم ليكون تقرير جاهز يتم حفظه pdf بعد الطباعة مع شكرى الجزيل

New Microsoft Excel Worksheet.xlsx

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

1-سبق و قلت لك في موقع اخر الاسماء بسيطة و غير معقدة

       ( التفتيش عن اسم بسيط للتأكد من  عمل الماكرو يصبح امراً سهلاً) و اذا نجح الماكرو تضعيتن الاسماء التي تريدينها

2- اي شيت تريدين ان يشمله الماكرو يجب ان يحتوي اسمه على "_"   "Under Score"

           كما في الملف المرفق

3- لا لزوم لأعداد كبيرة  1458.1587 في البداية فقط يكفي اعداد بسيط من 1 الى 10 للتأكد من  عمل الماكرو

      و اذا نجح الماكرو  تضعيتن الأرقام التي تريدينها

4 - لا حاجة لأربع صفحات لاخنبار الماكرو (يكفي صفحتين)

   و اذا نجح الماكرو  تضعيتن ما تريدين من صفحات

Option Explicit
Sub My_Total()
Rem Created By Halim Hasbaya On 15/7/ 2020
Dim Main As Worksheet
Dim sh As Worksheet
Dim arr(), m%, itm, x%, k%
Dim Ro%, S#, ky
Dim Dic As Object
Application.ScreenUpdating = False
m = 1
Set Main = Sheets("SUMOLL")
Main.Range("a2").Resize(10000, 2).Clear
Set Dic = CreateObject("Scripting.Dictionary")
For Each sh In Sheets
 If InStr(sh.Name, "_") Then
    ReDim Preserve arr(1 To m)
    arr(m) = sh.Name
    m = m + 1
  End If
Next
If m = 1 Then GoTo Thank_You
For Each itm In arr
    Set sh = Sheets(itm)
     Ro = sh.Cells(Rows.Count, 1).End(3).Row
    For x = 2 To Ro - 2 Step 2
       S = Application.Sum(sh.Cells(x + 1, 2).Resize(, 5))
       Dic(sh.Cells(x, 1).Value) = Dic(sh.Cells(x, 1).Value) + S
    Next x
Next itm
k = 2
If Dic.Count = 0 Then GoTo Thank_You
 For Each ky In Dic.keys
    With Main.Cells(k, "A")
    .Value = ky
    .Offset(1) = "TOTAL"
    .Offset(1).Resize(, 2). _
     Interior.ColorIndex = 20
    .Offset(1, 1) = Dic(ky)
    End With
  k = k + 2
    Next ky
    With Main.Range("A" & k + 1)
      .Value = "All Sum"
      .Offset(, 1).Formula = _
       "=SUM(B2:B" & k - 1 & ")"
      .Resize(, 2).Interior.ColorIndex = 8
    End With
 With Main.Range("A2:B" & k + 1)
  .Borders.LineStyle = 1
  .InsertIndent 1
  .Value = .Value
    With .Font
     .Size = 14: .Bold = True
    End With
 End With
Thank_You:
 Set Main = Nothing: Set sh = Nothing
 Set Dic = Nothing: Erase arr
 Application.ScreenUpdating = True
End Sub

الملف مرفق(عدد 2)

الأول حسب رغبتك

والثاني ما أراه مناسباً

اختاري ما تريدين (مع ابداء الرأي)

 

Yara_data.xlsm

Yara_data_1.xlsm

[yara ahmed]

حضرتك رائع رائع رائع جميل حميل جميل جميل

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

بس كده تحفة 

الملف الى حضرتك تراه مناسب طبعا طبعا انا ااراه مناسب طبعا 

انا بشكرك من قلبى بجد نفسى اقولك كل الكلام الحلو الى تستحقه والله

ميرسى جدااااااااااااااااااااااااااااااااااااااااااااا 

نفسى كمان يبقى فيه اسم الشيت يبقى كده التقرير متكامل تسلم لى ايدك والله

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

هذا الملف مع اسماء الشيتات حيث يتواجد كل عنصر مع مجموع كل شيت على حدة

 

Yara_data_With_count.xlsm

[yara ahmed]

يسعد ايامك يارب

حلو حلو يادكتور

تسلم وتعيش يارب حاجة جميلة ورائعة

انا يشكرك من قلبى والله 

كل الكلام الجميل مش هيديك حقك تعيش يارب وتسلم 

الف شكر والله مع خالص حبى وتقديرى لك

[yara ahmed]

فى مشكلة ياباشاhttps://www.officena.net/ib/profile/127744-سليم-حاصبيا/

الكود مش بيجمع الا الاسماء المتشابهة بس باقى الاسماء يتجاهلها

ولا يحضر باقى الاسماء التى بالعمود a 

عارف حضرتك التقرير الى بيحضر الشيت التى بالتاب الاخضر

لدى خمسة ملفات استخدم فيها كود التاب الاخضر الرائع الى عملتوهولى

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

اتمنى اكون شرحت لك تمام

 

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

الكود ليس له علاقة بلون التاب فقط يتعاطى مع الشيتات التي اسمها يحتوي  على Under score

اذا اردتي ان يقوم الماكرة بفحص الشيت الذي اسمه  ِAny sheet مثلاً  اجعلي اسمه  Any_sheet

الاسما تدرج جميعها (المكرر مرة واحدة)

اذا اردت اضافة اللون الى الشروط يجب اضافة شرط واحد على الكود كما في الصرورة

 

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

[yara ahmed]

ايو بص يادكتور ياجميل 

الكود الى بلون التاب بينتج عنه جدول من ملف وجدول من ملف تانى وهكذا خمس جداول

بعمل ورقة عمل فارغة وانسخ الخمس جداول

واعملهم جدول واحد طبعا بيطلع غلطات كتير

مش شرط اسمااء الاعمدة متشابة فى طبعا متشابه وفى غير متشابه

التقرير التجميعى المفروض يجمع لى

عمودين

عمود به اسماء الاعمدة وبجانب كل اسم مجموع المبالغ ال خمسة زى الملف الى انا رافعاه اول مشاركة

لو الاسم متشابه يجمعهم على بعض

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

ولا يحضر باقى اسماء الاعمدة

فاهمنى ياباشا

شكر من القلب