اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

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

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

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

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

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 فأين اريد   ان اجده)

 

  • Like 2
رابط هذا التعليق
شارك

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

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

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

البيانات في الاوراق ورقة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

  • Like 3
رابط هذا التعليق
شارك

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

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

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

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

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

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

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

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

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

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

  • Like 1
رابط هذا التعليق
شارك

السلام عليكم

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

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

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

ثانيا وهي ان في الملف الاصل توجد بيانات تعريفية واحصاء للبيانات في كل ورقة من 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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

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

Array101;Array102;Array103;Array104;Array105;Array106

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

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information