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

Elsayed Elgammal · يوليو 1, 2023

كل التحية والتقدير للزملاء

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

ملحوظة كل الجداول لها نفس الخلايا ونفس التنسيق لكن طبعا العدد بيختلف وممكن يزيد أو ينقص

تجميع التلاميذ.xlsx

**محمد هشام.** · يوليو 1, 2023

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

تفضل اخي

Sub importer()
  Dim i As Long, sh As Integer, lig As Long, j As Integer
  Dim wsData As Worksheet: Set wsData = Sheets("الجميع")
  
  With wsData
  Application.ScreenUpdating = False
   .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents
   For sh = 1 To Sheets.Count
    If Sheets(sh).Name <> wsData.Name Then
      For i = 5 To Sheets(sh).Range("B" & Rows.Count).End(xlUp).Row + 1
        If .Range("B5") = "" Then lig = 5 Else lig = .Range("B" & Rows.Count).End(xlUp).Row + 1
        For j = 2 To .Cells(4, Columns.Count).End(xlToLeft).Column
          .Cells(lig, j) = Sheets(sh).Cells(i, j)
            [A5] = 1
Range("a5:a" & Range("b" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear
        Next
      Next
    End If
   Next
  End With
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'لجلب البيانات تلقائيا يمكنك وضع هدا الرمز في حدث شيت الجميع 
Private Sub Worksheet_Activate()
Call importer
End Sub

ملاحظة قد تم وضعه مسبق يكفي فقط تفعيله في حالة الرغبة عن الاستغناء عن الزر لتنفيد الكود

v2 تجميع التلاميذ.xlsb

تم تعديل يوليو 1, 2023 بواسطه محمد هشام.

أبوأحـمـد · يوليو 1, 2023

يمكن أيضا التجميع عن طريق أداة برو كويري Power Query

المتوفرة بالأكسل والتحديث عن طريق بيانات

ملاحظة تم تحويل البيانات إلى جداول لتسهيل العمل

تجميع التلاميذ.xlsx

Elsayed Elgammal · يوليو 1, 2023

قمت بتجربة الكود وكان أكثر من رائع لكن نطمع في بعض التعديل بحيث يتم ترتيب الطلاب حسب كل فصل ، بالمناسبة أنا عامل جداول للفصول باسم معرف ( اسم جدول ) هل هذا مفيد في هذه الحالة ؟

كمان استفسار من الأخوة الـ ( بور كويري ) موجود في أي اصدار للأكسل أنا معنديش فكرة ولم استخدمه من قبل ونتعلم منكم وشكراً على سرعة الاهتمام والرد

**محمد هشام.** · يوليو 1, 2023

48 دقائق مضت, Elsayed Elgammal said:

نطمع في بعض التعديل بحيث يتم ترتيب الطلاب حسب كل فصل ، بالمناسبة أنا عامل جداول للفصول باسم معرف ( اسم جدول )

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

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

على العموم ادا كان هدا هو طلبك اجعل الكود بهده الطريقة

Sub importer()
  Dim i As Long, sh As Integer, lig As Long, j As Integer
  Dim wsData As Worksheet: Set wsData = Sheets("الجميع")
  With wsData
  Application.ScreenUpdating = False
   .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents
   For sh = 1 To Sheets.Count
    If Sheets(sh).Name <> wsData.Name Then
      For i = 5 To Sheets(sh).Range("a" & Rows.Count).End(xlUp).Row + 1
        If .Range("a5") = "" Then lig = 5 Else lig = .Range("a" & Rows.Count).End(xlUp).Row + 1
        For j = 1 To .Cells(4, Columns.Count).End(xlToLeft).Column
          .Cells(lig, j) = Sheets(sh).Cells(i, j)
        Next
      Next
    End If
   Next
  End With
End Sub

واي اضافة او تعديل لا تتردد في دكره سوف نكون سعداء لمساعدتك

بالتوفيق..

تم تعديل يوليو 1, 2023 بواسطه محمد هشام.

Elsayed Elgammal · يوليو 2, 2023

كرمكم شجعني على طلب المزيد ـ

أولا : لم يعد في حاجة لزر الأمر

مرفق الملف وأتمنى تعديل الكود لكي يتم جلب البيانات من أوراق عمل محددة وليس كل الشيتات مثلاً ( ورقة1 ) غير مطلوب جلب البيانات منها

راجع حدود العمود الأول ( عمود المسلسل ) في ورقة التجميع تتحول إلى خط مزدوج في كل تحديث حتى لو غيرنا تنسيق الحدود . فما هو السبب ؟؟

تجميع التلاميذ 2.xlsm

تم تعديل يوليو 2, 2023 بواسطه Elsayed Elgammal

**محمد هشام.** · يوليو 2, 2023

2 ساعات مضت, Elsayed Elgammal said:

أتمنى تعديل الكود لكي يتم جلب البيانات من أوراق عمل محددة وليس كل الشيتات مثلاً ( ورقة1 ) غير مطلوب جلب البيانات منها

يمكنك استثناء اي ورقة عمل بالطريقة التالية لنفترض اننا اردنا عدم جلب بيانات الورقة 1 والورقة 2 مثلا .

If Sheets(sh).Name <> wsData.Name And Sheets(sh).Name <> "ورقة1" And Sheets(sh).Name <> "ورقة2" Then

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

Sub All_School()
  Dim i As Long, sh As Integer, lig As Long, j As Integer
  Dim wsData As Worksheet: Set wsData = Sheets("All_School")
  With wsData
  Application.ScreenUpdating = False
   .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents
   For sh = 1 To Sheets.Count
     If Sheets(sh).Name <> wsData.Name And Sheets(sh).Name <> "ورقة1" Then
      For i = 5 To Sheets(sh).Range("B" & Rows.Count).End(xlUp).Row + 1
        If .Range("B5") = "" Then lig = 5 Else lig = .Range("B" & Rows.Count).End(xlUp).Row + 1
        For j = 2 To .Cells(4, Columns.Count).End(xlToLeft).Column
          .Cells(lig, j) = Sheets(sh).Cells(i, j)
            For F = 5 To wsData.Cells(Rows.Count, "B").End(xlUp).Row
             If wsData.Cells(F, "B").Value <> "" Then
               wsData.Cells(F, "a").Value = F - 4
            End If
          Next F
        Next
      Next
    End If
   Next
  End With
End Sub

تجميع التلاميذ 3.xlsm

تم تعديل يوليو 2, 2023 بواسطه محمد هشام.

Elsayed Elgammal · يوليو 2, 2023

تحية وتقدير للاهتمام والمجهود الكبير من الأخ الأستاذ الزميل

لكن عندي سؤال كنت أريد نذكر في الكود الشيتات المطلوب جلب البيانات منها وليس العكس

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

أقصد الأسهل نذكر في الكود أسماء الورقات المطلوبة وليس العكس وذلك للتسهيل . هل هذا ممكن ؟؟؟

هيسهل عليا العمل كثيرا وشكراً لكم سيدي

**محمد هشام.** · يوليو 2, 2023

نعم اخي يمكننا فعل دالك

تفضل

Sub All_School()

Dim Réf, A(), i&, F&, Y&, K&, last&, Sh As Variant
Dim Dest As Worksheet: Set Dest = Sheets("All_School")
last = Dest.Cells(Rows.Count, "a").End(xlUp).Row + 1
Application.ScreenUpdating = False


' يمكنك اظافة اسماء اوراق العمل المرغوب جلب البيانات منها بالطريقة التالية
' For Each Sh In Sheets(Array("class1", "class2", "class3", "class4", "class5", "class6"))

'هنا تمت اظافة 3 اوراق فقط للتجربة
For Each Sh In Sheets(Array("class1", "class2", "class4"))
 
  K = Sh.Range("B" & Rows.Count).End(xlUp).Row
      Réf = Sh.Range("B5:E" & K)
For i = 1 To UBound(Réf, 1)
Dest.Range("A5:E" & last).ClearContents
    Y = Y + 1: ReDim Preserve A(1 To UBound(Réf, 2), 1 To Y)
 For F = 1 To UBound(Réf, 2)
         A(F, Y) = Réf(i, F)
           Next
        Next
 With Dest
 Dest.Range("B5").Resize(Y, UBound(A, 1)) = Application.Transpose(A)
       End With
   Next Sh
   For F = 5 To Dest.Cells(Rows.Count, "B").End(xlUp).Row
             If Dest.Cells(F, "B").Value <> "" Then
            Dest.Cells(F, "a").Value = F - 4
        End If
    Next F

End Sub

تجميع التلاميذ 4.xlsm

تم تعديل يوليو 2, 2023 بواسطه محمد هشام.

Elsayed Elgammal · يوليو 3, 2023

تحية تقدير وإجلال لحضرتك

هجرب وأشوف

Elsayed Elgammal · يوليو 3, 2023

للأسف حاولت أعدل في الكود على البرنامج عندي لكن لم أتمكن أرجو المساعدة في تعديل الكود

أرجو أن تكون البيانات حتى العمود X

غيرت اسم module هل ممكن سبب مشكلة

حاولت أرفق ملف جديد للتعديل لكن رفض الموقع لأنه أكثر من 2 ميجا سوف أرسله على خاص حضرتك او مسنجر

بس عرفني الطريقة والعنوان

تم تعديل يوليو 3, 2023 بواسطه Elsayed Elgammal

Elsayed Elgammal · يوليو 3, 2023

'أرجو تعديل الكود حيث عند نسخه وتفعيله يترك 95 صف فارغ ثم يأتي بأسماء طلاب الصف التالي وهكذا

'أين الخطأ مستر محمد ؟؟؟

Sub All_School() 'by MOHAMMED HICHAM -----------Modified on 02/07/2023

Dim Réf, A(), i&, F&, Y&, K&, last&, Sh As Variant

Dim Dest As Worksheet: Set Dest = Sheets("All_School")

last = Dest.Cells(Rows.Count, "a").End(xlUp).Row + 1

Application.ScreenUpdating = False

' يمكنك اظافة اسماء اوراق العمل المرغوب جلب البيانات منها بالطريقة التالية

' For Each Sh In Sheets(Array("class1", "class2", "class3", "class4", "class5", "class6"))

'هنا تمت اظافة 3 اوراق فقط للتجربة

For Each Sh In Sheets(Array("kg1", "kg2", "C1", "C2", "C3", "C4", "C5", "C6"))

K = Sh.Range("B" & Rows.Count).End(xlUp).Row

Réf = Sh.Range("B6:x" & K)

For i = 1 To UBound(Réf, 1)

Dest.Range("A5:x" & last).ClearContents

Y = Y + 1: ReDim Preserve A(1 To UBound(Réf, 2), 1 To Y)

For F = 1 To UBound(Réf, 2)

A(F, Y) = Réf(i, F)

With Dest

Dest.Range("B5").Resize(Y, UBound(A, 1)) = Application.Transpose(A)

End With

Next Sh

For F = 5 To Dest.Cells(Rows.Count, "B").End(xlUp).Row

If Dest.Cells(F, "B").Value <> "" Then

Dest.Cells(F, "a").Value = F - 4

End If

Next F

End Sub

**محمد هشام.** · يوليو 3, 2023

أخي لقد تم تعديل الملف اكثر من 4 مرات.

والان نكتشف أن البيانات حتى العود x !!!!!!

1)هل قمت بتجربة الملف في المرفقات

2) لا يمكنني مساعدتك بدون إرفاق الملف الأصلي أو نسخة طبق الأصل. تفاديا لاهدار الوقت بدون فائدة

**محمد هشام.** · يوليو 3, 2023

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

تمت تجربة الملف ويشتغل بدون ادنى مشكلة

Sub TEST()
Dim Réf, A(), i&, F&, Y&, K&, last&, Sh As Variant
Dim Dest As Worksheet: Set Dest = Sheets("All_School")
last = Dest.Cells(Rows.Count, "b").End(xlUp).Row + 1
Application.ScreenUpdating = False
For Each Sh In Sheets(Array("kg1", "kg2", "C1", "C2", "C3", "C4", "C5", "C6"))
  K = Sh.Range("B" & Rows.Count).End(xlUp).Row
      Réf = Sh.Range("B6:x" & K)
For i = 1 To UBound(Réf, 1)
Dest.Range("A6:X" & last).ClearContents
    Y = Y + 1: ReDim Preserve A(1 To UBound(Réf, 2), 1 To Y)
 For F = 1 To UBound(Réf, 2)
         A(F, Y) = Réf(i, F)
           Next
        Next
 With Dest
 Dest.Range("B6").Resize(Y, UBound(A, 1)) = Application.Transpose(A)
       End With
   Next Sh
   For F = 6 To Dest.Cells(Rows.Count, "B").End(xlUp).Row
             If Dest.Cells(F, "B").Value <> "" Then
            Dest.Cells(F, "a").Value = F - 5
        End If
    Next F
 

End Sub

test05.xlsm

تم تعديل يوليو 3, 2023 بواسطه محمد هشام.

Elsayed Elgammal · يوليو 3, 2023

لا أجد ما أعبر به من الكلمات عن مدى شكري وتقديري لمساعدتكم فأنا مبتدئ في الـ VBA وكنت آمل المزيد من سعة صدركم لكن ألف مرة شكرا

**محمد هشام.** · يوليو 3, 2023

الان, Elsayed Elgammal said:

كنت آمل المزيد من سعة صدركم لكن ألف مرة شكرا

العفو اخي الهدف عندنا هو حصولك على النتيجة المطلوبة. رغم انك لم تاكد لنا لحد الساعة هل حصلت عليها ام لا

ملاحظة : شخصيا لا يهمني الاشتغال على الملف ولو 1000 مرة لاكن بشرط ان تكون الطلبات معقولة . وغير مكررة كما يفضل دائما اخي الكريم ارفاق ملف شبيه لملفك الاصلي او ارفاقه مع حدف البيانات الحساسة منه . هناك اشياء ربما تبدو لك غير مهمة وبسيطة كدمج خليه معينة مثلا قد يسبب عدم اشتغال الكود بشكل الصحيح .عند نقله الى الملف الاصلي

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

بالتوفيق

**محمد هشام.** · يوليو 4, 2023

10 ساعات مضت, Elsayed Elgammal said:

فأنا مبتدئ في الـ VBA وكنت آمل المزيد من سعة صدركم

بما انك مبتدا اليك حل اخر ربما يناسبك ميزته انه سيعفيك من تعديل الاكواد واظافة اسماء الشيتات حيث يتم كل شيء تلقائيا دون تدخل منك يكفي فقط اظافة اي قيمة تعجبك امام الشيت المرغوب جلب بياناته

(لم اقم بتحديدها لتبقى لك الحرية التامة في الاستخدام )

اليك رابط طريقة الاستخدام للتوضيح

نسخ البيانات من عدة اوراق عمل بشرط تحديدها في عمود (streamable.com)

الاكواد المستخدمة

Sub All_School()
Dim wsArr() As String                           
Dim sh&, Y&, c As Range, Rng2 As Range, R As Range
Dim a As Long, rng As Long, b As Long, J As Long, LastRow As Long
Dim ST1 As Worksheet, Dest As Worksheet
Application.ScreenUpdating = False

Set Dest = Sheets("All_School")
  For Each ST1 In Sheets
    If ST1.Name <> Dest.Name Then
      Set R = Dest.Range("AA:AA").Find(ST1.Name, , xlValues, xlWhole, , , False)
      If Not R Is Nothing Then
        If Dest.Range("AB" & R.Row).Value <> "" Then
LastRow = Dest.Cells(Rows.Count, "B").End(xlUp).Row + 1
  
  J = Dest.Range("AA" & Rows.Count).End(xlUp).Row
    Set Rng2 = Dest.Range("AB2:AB" & J)
        If Application.WorksheetFunction.CountIf(Dest.Range("AB2:AB" & J), "<>") > 0 Then
For Each c In Rng2
If c Then
 If c <> "" Then
ReDim Preserve wsArr(0 To sh)
 wsArr(sh) = c.Offset(, -1).Value
          sh = sh + 1
             Else
          Exit Sub
       End If
    End If
  Next
Dest.Range("A5:X" & LastRow).ClearContents
For K = LBound(wsArr) To UBound(wsArr)
With Worksheets(wsArr(K))
.Activate
a = Range("A" & Rows.Count).End(xlUp).Row
ws = Range("B5:X" & a)
End With
b = Dest.Range("B" & Rows.Count).End(xlUp).Row
With Dest.Cells(b + 1, "B")
    .Resize(UBound(ws, 1), UBound(ws, 2)) = ws
End With
Next
Dest.Activate
For f = 5 To Dest.Cells(Rows.Count, "B").End(xlUp).Row
If Dest.Cells(f, "B").Value <> "" Then
Dest.Cells(f, "A").Value = f - 4
          End If
       Next f
      End If
  Exit Sub      
  End If
  End If
           Else
        MSG = MsgBox("المرجوا التأكد من أسماء أوراق العمل المرغوب جلب البيانات منها ", vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, "انتباه")
         
    End If
  Next
End Sub

هدا الكود في حدث شيت ("All_School")

Private Sub Worksheet_Activate()
 Call ListSheets
End Sub
'''''''''''''''''''''''''''''''''''''''''''''
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, LastRow As Long
Dim Dest As Worksheet: Set Dest = Sheets("All_School")
If Target.Column = 28 Then
LastRow = Dest.Range("aa" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
For Each rng In Range("AB2:AB" & LastRow)
            If rng.Value <> "" And rng.Offset(, -1).Value <> "" Then
                Call All_School
            End If
        Next
If Application.WorksheetFunction.CountIf(Sheets("All_School").Range("ab2:ab" & LastRow), "<>") = 0 Then
Dest.Range("A5:x1000").ClearContents
      End If
Application.EnableEvents = True
    End If
End Sub

وهدا في موديول

Sub ListSheets()       '("AA:AB") في حالة نقل الكود الى ملف اخر تأكد من وجود الجدول في نفس الاعمدة المدكورة
                                 '("Table1") وتطابق اسمه مع الاسم الموجود داخل الكود
Dim x As Integer
Dim WSdata As Worksheet
Dim ws As Worksheet: Set ws = Sheets("All_School")
Application.ScreenUpdating = False
Dim tbl As ListObject
Set tbl = ws.ListObjects("Table1")
With tbl.DataBodyRange
    If .Rows.Count > 1 Then
      .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
    End If
End With
tbl.DataBodyRange.Rows(1).ClearContents
x = 2
For Each WSdata In Worksheets
If WSdata.Name <> ws.Name Then
     ws.Cells(x, 27) = WSdata.Name   'column AA
     x = x + 1
     End If
Next
End Sub

Test MH.xlsm

تم تعديل يوليو 4, 2023 بواسطه محمد هشام.

Elsayed Elgammal · يوليو 4, 2023

هجرب أخي الكريم وأشوف

والله أنا خجلان من مجهودك ولا أعرف كيف أجازيك لكن عندي طلب أخير وهو هل ممكن نطلب من الكود ينسخ حتى 60 صف فقط لأن All في الكود تقوم بنسخ أي بيانات حتى لو ملاحظات في نهاية أوراق العمل . والآن عندي مشكلة عند احضار البيانات فإن كل صف مضبوط لكن يترك صفوف فارغة كثيرة ثم الصف التالي وهكذا

وأنا الآن أدرس الكود لأتعلم ومع منتدى أوفيسنا الرائع وفيديوهات أخرى من اليوتيوب أتعلم بالتدريج ,انا أفهم المقصود من كلامك لكن الملف تقيل وحتى الضغط لم ينفع

أشكركم وطبعا كل اللي اتعمل أفادني كثيراً ...

تم تعديل يوليو 4, 2023 بواسطه Elsayed Elgammal

**محمد هشام.** · يوليو 4, 2023

نعم اخي يمكننا تحديد اقصى عدد للصفوف المرحلة رغم ان مثل هده الامور كان من المفروض اما ادراجها على الملف المرفق في المشاركة او على الاقل الاشارة اليها .

يبدوا لي انك لازم ترفق ملفك لنتمكن من تحديد النطاقات المرغوب الاشتغال عليها . او ملف مشابه تمام مع بعض البيانات الوهمية

لقد حاولت وضع بين يديك جميع الحلول التي ممكن ان تساعدك... للاسف لا يمكنني معرفة التفاصيل الدقيقة الا عند معاينة الملف .

Elsayed Elgammal · يوليو 5, 2023

شكرا على الاهتمام وسوف أحاول عمل ملف خفيف وتنزيله

تسجيل الدخول

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

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

Elsayed Elgammal

محمد هشام.

أبوأحـمـد

Elsayed Elgammal

محمد هشام.

Elsayed Elgammal

محمد هشام.

Elsayed Elgammal

محمد هشام.

Elsayed Elgammal

Elsayed Elgammal

Elsayed Elgammal

محمد هشام.

محمد هشام.

Elsayed Elgammal

محمد هشام.

محمد هشام.

Elsayed Elgammal

محمد هشام.

Elsayed Elgammal

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information