استدعاء البيانات من اوراق عديدة الى ورقة واحدة متسلسلة وبدون فراغات

[مصطفى محمود مصطفى]

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

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

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

وفقكم الله وحفظكم من كل سوء

Option Explicit

Sub join_data()
Application.ScreenUpdating = False
Dim My_rg As Range
Dim m%: m = 6
Dim r%
Dim ara
Range("c6:H" & Rows.Count).ClearContents
Set My_rg = Union(Range("R_G_1"), Range("R_G_2"), Range("R_G_3"), Range("R_G_4"))
 
  For Each ara In My_rg.Areas
   r = ara.Rows.Count
   Range("c" & m).Resize(r, 6).Value = ara.Value

   m = m + r
   Next
  
    Range("B1").Select
    Application.ScreenUpdating = True

End Sub

توزيع القديم تلاميذ مدرستنا2020 حسب المعدلات على الشعب.xlsm

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

يا اخي 

كن واضحاً في سؤالك

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

ما هي اوراق المصدر ؟؟؟ و ما هي الورقة الهدف  ولم أر الماكرو المذكور في الملف الذي يحتوي على اكثر من Module فأين اريد   ان اجده)

 

[مصطفى محمود مصطفى]

الله يحفظكم اخي الاستاذ سليم

 رابط الموضوع الذي به الكود

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

البيانات في الاوراق ورقة1 وورقة2وورقة3 وورقة 4 وورقة5 وورقة6 تنقل الى ورقة all دون فراغات ومدى كل ورقة 105

لكم كل الشكر والتقدير استاذنا العزيز

استدعاء البيانات من اوراق عديدة الى ورقة واحدة.xlsx

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

جرب هذا الكود

Option Explicit
Sub Get_Data()
    Dim A       As Worksheet
    Dim sh      As Worksheet
    Dim ar(), itm
    Dim lr%, m%, t%, Mmax%
    Dim R_copy As Range
Set A = Sheets("all")

m = -1: t = 4
If A.Range("A3").CurrentRegion.Rows.Count > 1 Then
 
    With A.Range("A3").CurrentRegion.Offset(1). _
      Resize(A.Range("A3").CurrentRegion.Rows.Count - 1)
      .Interior.ColorIndex = xlNone
      .ClearContents
     End With
 
 End If

For Each sh In Sheets
      If sh.Name <> A.Name Then
        m = m + 1
        ReDim Preserve ar(m)
        ar(m) = sh.Name
      End If
  Next
  If m > 0 Then
      For Each itm In ar
          Set sh = Sheets(itm)
        Set R_copy = sh.Range("A3").CurrentRegion
         Mmax = R_copy.Rows.Count
         If Mmax > 1 Then
            With A.Cells(t, 1)
             .Resize(, 8).Interior.ColorIndex = 6
             .Resize(Mmax - 1, 8).Value = _
             sh.Range("A3").CurrentRegion.Offset(1).Resize(Mmax - 1).Value
             t = t + Mmax - 1
            End With
         End If 'Mmax
      Next
  End If 'm
End Sub

الملف مرفق

Moustafa.xlsm

[مصطفى محمود مصطفى]

احسنتم استاذ سليم وفقكم الله وحفظكم

كود اكثر من رائع تقبلوا وافر احترامي وتقديري

اردت تعديل بسيط بان يرحل البيانات من العمود b الى العمود b ويبقي التسلسل فارغ للعد بالمعادلات من 1 الى اخر صف

او تعديل بالكود بان هو يجعل التسلسل مستمر من 1 الى اخر عدد به بيانات مثلا 300 او اكثر او اقل

جزاكم الله خيرا

تم تعديل ديسمبر 23, 2020 بواسطه مصطفى محمود مصطفى

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

اضافة هذا السطر على الكود في المكان المناسب

 

[مصطفى محمود مصطفى]

الله يحفظكم اخي الاستاذ سليم المبدع

تم اضافة السطر ويعمل بشكل رائع

End If 'Mmax
      Next
      A.Cells(4, 1).Resize(t - 4).Value = _
      Evaluate("row(1:" & t - 1 & ")")
      
  End If 'm
End Sub

وفقكم الله وانعم عليكم بالصحة والعافية

[مصطفى محمود مصطفى]

السلام عليكم

الاستاذ الفاضل سليم حفظكم الباري عز وجل

حدثت مشكلتين عند نقل الكود الى الملف الاصل 

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

ثانيا وهي ان في الملف الاصل توجد بيانات تعريفية واحصاء للبيانات في كل ورقة من a1 الى h2 الكود يقوم باستدعاءها كذلك الا اذا كان السطر الذي يسبق العناوين فارغ .

هل يمكن ان نحدد البيانات المراد نسخها من a4 فقط ونستثني ما فوقه ؟

هذا مجرد حاجة لضبط الكود ليتوافق مع عملي في الملف وانا اضفت صف واخفيته وجعلته فارغا لكن عليّ ان اغير بعض المعادلات واكود الترحيل وغيره في جميع الاوراق المصدر

اذا كان بالامكان استاذي العزيز تجاوز هذه الملاحظات

لكم فائق الاحترام والتقدير

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

اذكر ان الجدول يجب ان يكون مستقلاً عن كل الخلايا التي لا غلاقة له بها بصفوف فارغة وأعمدة فارغة)

اجمع كل الأوراق التي تريدها في Array  واحد و اعمل حلقة على هذا الـــ Array

Option Explicit
Sub Get_Spacial_Data()
    Dim A       As Worksheet
    Dim sh      As Worksheet
    Dim ar, itm
    Dim lr%, m%, t%, Mmax%
    Dim R_copy As Range
Set A = Sheets("all")

 t = 4
If A.Range("A3").CurrentRegion.Rows.Count > 1 Then
 
    With A.Range("A3").CurrentRegion.Offset(1). _
      Resize(A.Range("A3").CurrentRegion.Rows.Count - 1)
      .Interior.ColorIndex = xlNone
      .ClearContents
     End With
 
 End If
 '+++++++++++++++++++++++++++++++++++++++++
     ' Add to the array the Sheets you want
     ar = Array("1", "2", "3", "4", "5", "6")
'++++++++++++++++++++++++++++++++++++++
      For Each itm In ar
          Set sh = Sheets(itm)
        Set R_copy = sh.Range("A3").CurrentRegion
         Mmax = R_copy.Rows.Count
         If Mmax > 1 Then
            With A.Cells(t, 1)
             .Resize(, 8).Interior.ColorIndex = 6
             .Resize(Mmax - 1, 8).Value = _
             sh.Range("A3").CurrentRegion.Offset(1).Resize(Mmax - 1).Value
             t = t + Mmax - 1
            End With
         End If 'Mmax
      Next

End Sub

 

[مصطفى محمود مصطفى]

الاستاذ المبدع دائما وابدا سليم وفقكم الله

شكرا لكم على استجابتكم السريعة 

اسميت كل مدى في الاوراق اسم وجمعتهم تحت مسمى واحد Array والعمل رائع

Array101;Array102;Array103;Array104;Array105;Array106

لكم وافر احترامي وتقديري