اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

تجميع بيانات من اكثر من شيت لاسماء مختلفه باستخدام قائمه منسدله

ايهاب السيد بدوى
 مشاركة
إذهب إلى الإجابة الإجابة بواسطة سليم حاصبيا,

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

ايهاب السيد بدوى

ايهاب السيد بدوى

قام بنشر
قام بنشر

السلام عليكم ورحمه الله تعالى وبركاته 

يوجد فى شيت رقم 1 اسماء وكل اسم له مبلغ وضريبه ودمغه

وفى شيت رقم 2 يوجد اسماء من شيت رقم 1 واسماء مختلفه لا توجد فى شيت رقم 1وامام كل اسم مبلغ وضريبه ودمغه وخانه 1% 

وفى شيت رقم 3 يوجد نفس الاسماء من شيت رقم 1 و2 واسماء مختلفه 

اريد فى الشيت النهائى عند كتابه الاسم او باستخدام قائمه منسدله يتم تجميع  خانه المبلغ  وخانه الضريبه وخانه الدمغه وخانه 1% الموجود امام كل اسم  فى شيت رقم 1 و2و3 ويتم وضع المجموع امام الاسم فى الشيت النهائى فى خانه المبلغ وخانه الضريبه وخانه الدمغه وخانه 1%

واذا كان اسم الشخص موجود فى شيت رقم 1 وله مبلغ فى خانه المبلغ ولايوجد اسمه فى شيت رقم 2 واسمه موجود فى شيت رقم 3 وله مبلغ فى خانه المبلغ فبالتالى يجمع المبلغ فى شيت رقم 1 و 3

وفى ملف مرفق

ولكم جزيل الشكر

 

بيانات.rar

ايهاب السيد بدوى

ايهاب السيد بدوى

قام بنشر
  • الكاتب
قام بنشر

شكرا استاذ سليم على ردك 

سؤال اخر اذا اردت ان اجعل  الكود يعمل فى حاله وجود اعمده اكتر بمعنى ان اريد ان يبحث فى حاله وجود اكثر من عمود واريد انا اجمع عن اعمده معينه فقط تكون اسماء الاعمده فيها خاضع او ضريبه كسب العمل او دمغه عاديه فقط ولا يجمع ارقام فى اعمده اخرى 

 

ايهاب السيد بدوى

ايهاب السيد بدوى

قام بنشر
  • الكاتب
قام بنشر

شكرا استاذ سليم على ردك 

فى المرفق ده بعد اذنك  لو انا عاوز اجمع فقط الاعمده بعنوانين غير خاضع وخاضع وضريبه كسب العمل والدمغه العدايه ولمواجهه الاوبئه وصندوق الاعاقه فقط ولا يجمع باقى الاعمده 

 

Book1.xlsx

ايهاب السيد بدوى

ايهاب السيد بدوى

قام بنشر
  • الكاتب
قام بنشر

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

اذا اردت مثلا فى شيت result انا اجمع مثلا الاعمده الخاصه بخانه غبر خاضع وخانه خاضع اسفل خانه الجمله والاعمده الخاصه بخانه اجمالى الاجر والاعمده الخاصه بخانه غير خاضع وبخانه خاضع اسفل خانه الاجر الاضافى والاعمده الخاصه بخانه الضريبه والاعمده الخاصه بخانه الدمغه والاعمده الخاصه بخانه جمله المستحقات

Ihab.rar

  • Like 1
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الماكرو (حتى لو تكرر الاسم في نفس الصفحة يقوم الماكرو بايجاده  مع تلوينه)   مثلاً   "كريم عفيفى" 

Sub Data_Sum_1()
  Dim Res As Worksheet
  Dim sh As Worksheet
  Dim ro1%, ro2%, K%
  Dim F_rg As Range
  Dim Ar

Set Res = Sheets("Result")
Ar = Array(0, 0, 0, 0, 0, 0, 0, 0)

Res.Range("A3:I3").ClearContents

If Res.Cells(1, "K") = vbNullString Then Exit Sub
For Each sh In Sheets
    If sh.Name <> "Result" Then
       sh.Range("A3:J1000"). _
       Interior.ColorIndex = xlNone
        Set F_rg = sh.Range("A:A"). _
         Find(Res.Cells(1, "K"), lookat:=1)
           
           If Not F_rg Is Nothing Then
              ro1 = F_rg.Row: ro2 = ro1
              Do
                 sh.Cells(ro2, 1).Resize(, 10). _
                 Interior.ColorIndex = 35
                 
                 For K = LBound(Ar) To UBound(Ar)
                  Ar(K) = Ar(K) + Val(sh.Cells(ro2, 3).Offset(, K))
                 Next
                Set F_rg = sh.Range("A:A").FindNext(F_rg)
                ro2 = F_rg.Row
                If ro1 = ro2 Then Exit Do
              Loop
          End If
    End If
 Next sh
 
 With Res.Cells(3, 1)
 .Value = Res.Cells(1, "K")
 .Offset(, 1).Resize(, UBound(Ar) + 1) = Ar
 End With

End Sub

الملف مرفق

 

Ihab_summation.xlsm

  • Like 3
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

لا تحكم على شيء دون ان تتأكد

لا حظ  عبد الكريم سلام   

(عدد الساعات لا تتم حسابها) لانك لم تضعها في الجدول في الصفحة Result

في الصفحة الأولى :
1- من C7  الى J7      في كل خلية 1
2- من C10  الى J10    في كل خلية 1
في الصفحة الثّانية :
1- من C6  الى J6       في كل خلية 1
2- من C10  الى J10    في كل خلية 1
3- من C13  الى J13   في كل خلية 1

المحموع العام في كل حلية  5  وهذا ما تجده في الصفحة Result

Ihab_summation_1.xlsm

Screenshot_1.png

  • Like 1
  • Thanks 1
ايهاب السيد بدوى

ايهاب السيد بدوى

قام بنشر
  • الكاتب
قام بنشر

 

ممكن عمل كود فى هذا الشيت الجديد باستخدام قائمه منسدله فى شيت result  يجمع المبالغ فى اكثر من شيت مع العلم انه ممكن ان يكون اكثر من شيت حتى شهر ديمسبر  باسماء اخرى غير الموجوده فى شيت يناير وفبراير ومارس وابريل 

Book34.rar

سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الملف
1- يمكن ان تختار اسم واحد أو كل الاسماء
2- الجمع يتم على الأعمدة E و F و I و J من كل صفحة (تم عمل حساب تكرار الاسم في الصفحة الواحدة)

3- يالنسبة للاسم الواحد 

Sub Data_Sum_1()
  Dim Res As Worksheet
  Dim Sh As Worksheet
  Dim ro1%, ro2%, K%
  Dim F_rg As Range
  Dim Ar

Set Res = Sheets("Result")
Ar = Array(0, 0, 0, 0)

If Res.Range("A1").CurrentRegion.Rows.Count > 2 Then
    Res.Range("A1").CurrentRegion.Offset(2). _
    Resize(Res.Range("A1").CurrentRegion.Rows.Count - 2).Clear
  End If

If Res.Cells(2, "H") = vbNullString Then Exit Sub
For Each Sh In Sheets
    If Sh.Name <> "Result" Then
       Sh.Range("A3:J1000"). _
       Interior.ColorIndex = xlNone
        Set F_rg = Sh.Range("B:B"). _
         Find(Res.Cells(2, "H"), lookat:=1)
           
           If Not F_rg Is Nothing Then
              ro1 = F_rg.Row: ro2 = ro1
              Do
                 Sh.Cells(ro2, 1).Resize(, 10). _
                 Interior.ColorIndex = 35
                 
                      Ar(0) = Ar(0) + Val(Sh.Cells(ro2, 5))
                      Ar(1) = Ar(1) + Val(Sh.Cells(ro2, 6))
                      Ar(2) = Ar(2) + Val(Sh.Cells(ro2, 9))
                      Ar(3) = Ar(3) + Val(Sh.Cells(ro2, 10))
                
                Set F_rg = Sh.Range("B:B").FindNext(F_rg)
                ro2 = F_rg.Row
                If ro1 = ro2 Then Exit Do
              Loop
          End If
    End If
 Next Sh

 With Res.Cells(3, 1)
 .Value = 1
 .Offset(, 1) = Res.Cells(2, "H")
 .Offset(, 2).Resize(, UBound(Ar) + 1) = Ar
    With .Resize(, UBound(Ar) + 3)
       .Borders.LineStyle = 1
       .Font.Size = 14
       .Font.Bold = True
       .InsertIndent 1
       .Interior.ColorIndex = 35
     End With
 End With

End Sub

بالنسبة لكل الاسماء 

Sub Data_Sum_ALL()
  Dim Res As Worksheet
  Dim Sh As Worksheet
  Dim ro1%, ro2%, K%
  Dim F_rg As Range
  Dim Ar
  Dim OBJ As Object, ky
  Dim m%, t%
      
      Set OBJ = CreateObject("Scripting.Dictionary")
      Set Res = Sheets("Result")
  If Res.Range("A1").CurrentRegion.Rows.Count > 2 Then
    Res.Range("A1").CurrentRegion.Offset(2). _
    Resize(Res.Range("A1").CurrentRegion.Rows.Count - 2).Clear
  End If
      For Each Sh In Sheets
       If Sh.Name <> "Result" Then
         m = 3
         Do Until Sh.Cells(m, 2) = vbNullString
          OBJ(Sh.Cells(m, 2).Value) = vbNullString
          m = m + 1
         Loop
       End If
      Next Sh
 Ar = Array(0, 0, 0, 0)
 If OBJ.Count Then
 t = 3
For Each ky In OBJ.keys
      For Each Sh In Sheets
            If Sh.Name <> "Result" Then
                Set F_rg = Sh.Range("B:B").Find(ky, lookat:=1)
                If Not F_rg Is Nothing Then
                    '+++++++++++++++++++++++
                    ro1 = F_rg.Row: ro2 = ro1
                    Do
                      Ar(0) = Ar(0) + Val(Sh.Cells(ro2, 5))
                      Ar(1) = Ar(1) + Val(Sh.Cells(ro2, 6))
                      Ar(2) = Ar(2) + Val(Sh.Cells(ro2, 9))
                      Ar(3) = Ar(3) + Val(Sh.Cells(ro2, 10))
                    
                      Set F_rg = Sh.Range("B:B").FindNext(F_rg)
                      ro2 = F_rg.Row
                      If ro1 = ro2 Then Exit Do
                    Loop
                
                '++++++++++++++++++++++++++
                
                End If 'F_rg
            End If 'Sh
            
      Next Sh
            Res.Cells(t, 2) = ky
            Res.Cells(t, 3).Resize(, UBound(Ar) + 1) = Ar
            Ar = Array(0, 0, 0, 0)
            t = t + 1
 Next ky
    With Res.Range("A3").Resize(t - 3, 6)
    .Columns(1).Value = _
     Evaluate("Row(1:" & t - 3 & ")")
    .Borders.LineStyle = 1
    .Font.Size = 14
    .Font.Bold = True
    .InsertIndent 1
    .Interior.ColorIndex = 35
    End With
 End If 'dic.count
End Sub

الملف مرفق

Ihab_ALL.xlsm

  • Like 2
  • Thanks 1
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept