جمع الشيتات في شيت واحد

[asad1391]

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

جمع الشيتات في شيت واحد ولكن روس الشيتات تختلف من شيت الى شيت 

ولك وافر الشكر والتقدير لك جميعا

المصنف3.xlsx

[محمد هشام.]

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

المشكلة ليست في رؤوس الأعمدة المختلفة ولا في مكان وجودها ضمن كل ورقة 

المشكلة في أسمائها المكررة على نفس الملف أكثر من مرة  أعتقد أنه يمكنك الاعتماد على الصف 19 كعناوين للمجموعات مثلا (المهارات الرقمية-اللغة الإنجليزية )  وعند وجودها  يتم البحث  عن تطابق الفرع الصف 20  (واجبات-مشاركة)  وهكدا.... لكي تتمكن من التغلب على مسألة تكرار رؤوس الأعمدة وجلب بيانات كل عمود في مكانه المناسب  لاحظ معي فرع الوجبات فقط لورقة واحدة في الصورة المرفقة 

بالنسبة للنتائج ستكون على الشكل التالي على حسب احتياجاتك إما نسخها كقيم أو مع التنسيقات 

ادا كان هدا ما تنوي فعله قم باختيار الطريقة المناسبة لك وسوف نكون سعداء بمساعدتك 

بالتوفيق .....

 

[asad1391]

الله يحفظكم ويبارك فيكم

نسخها مع التنسيقات 

والله ولي التوفيق 

[asad1391]

نسخها مع التنسيقات 

[asad1391]

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

الاخ / محمد هشام

احتاج الكود الذي يعمل بجمع الشتات كما تفضلت 

والمعذرة على الازعاج

 

[محمد هشام.]

آسف  أخي  @saad1391 فعلا  لم انتبه لردك  إلا بالصدفة

كان الفكرة الموضحة في الصور  قد تم تنفيذها يدويا لاكن بعد محاولة تنفيذها بواسطة الأكواد إكتشفت ان طريقة تصميمك للملف وكثرة الخلايا المدمجة يصعب التعامل معها حاول إلغاء دمجها قدر الإمكان للتخلص من الأعمدة الفارغة التي تعيق استخراج النتائج بشكل صحيح  

[محمد هشام.]

جرب هدا بعد تنفيد ما سبق دكره سابقا 

Sub CopyDataOnGroups()
Dim lastrow&, r&, Irow&
Dim ShtOne As Worksheet, WS As Worksheet
Dim rng As Boolean, arr As Variant, tmp As Range
Dim lingHeader As Range, cell As Range, data As Variant
Dim ColHeader As Range, a As Range, OnRng As Range
Dim Group As Boolean, n As Boolean

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
Set ShtOne = Sheets("التجميع")
ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear

arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")

For Each sheetName In arr
     Set WS = Sheets(sheetName)
     lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

If lastrow < 1 Then GoTo NextSheet

For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells
If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1)

For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1))

Group = False
n = False
rng = False

For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells
    If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1)

    If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then
        Group = True

        For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _
        ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1))

            If Trim(tmp.Value) = Trim(a.Value) Then
                n = True

                Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column))

                r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row

                Irow = r + 1
                
        For Each cell In OnRng
            data = cell.Value
            If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then
                rng = True
                Exit For
            End If
        Next cell

        If Not rng Then
            OnRng.Copy
                ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
                Application.CutCopyMode = False
                
                   End If
                Exit For
            End If
        Next a
    End If

         If Group And n Then Exit For
         Next ColHeader
      Next tmp
   Next lingHeader
NextSheet:
Next sheetName

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

 

المصنف 4.xlsb

[asad1391]

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

الاخ / محمد هشام

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

والشكر موصول للجميع

واسأل الله لنا ولكم التوفيق والسداد وان يجعلها في ميزان حسناتكم وجزاكم الله خيرا

وارجو المعذرة منكم على الازعاج