استدعاء البيانات من عدة شيتات إلى عمود واحد

[hassan rady]

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

اعضاء المنتدى المحترفين 

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

اريد جلب كل البيانات الي في هذا العمود الى عمود واحد

متأكد انكم ما تخيبوا ظني احبتي

شكرا لكم

1.xlsx

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

جرب هذا الكود

Option Explicit
Sub get_all()
Dim Sh As Worksheet
Dim My_rg As Range
Dim Arr(), I%, k%, m%
 m = 2
For Each Sh In Sheets
 If UCase(Sh.Name) <> UCase("salim") Then
  ReDim Preserve Arr(k)
    Arr(k) = Sh.Name
    k = k + 1
 End If
 Sheets("Salim").Range("B:B").ClearContents

Next Sh
 For k = LBound(Arr) To UBound(Arr)
 Set My_rg = Sheets(Arr(k)).Range("b1").CurrentRegion
  If My_rg.Rows.Count = 1 Or _
   Sheets(Arr(k)).Range("B1") = "" Then GoTo next_K
   Set My_rg = _
   My_rg.Offset(1).Resize(My_rg.Rows.Count - 1).Columns(1)
   My_rg.Copy Sheets("Salim").Range("B" & m)
   m = m + My_rg.Rows.Count
next_K:
 Next k
 Sheets("Salim").Range("B1") = "Data"
End Sub

الملف مرفق

H_Rady.xlsm

[yara ahmed]

كود ممتاز

[hassan rady]

آسف على التأخير شكرا لك استاذ سليم على الدعم ممتن لك

في شي انا ما وضحته ممكن يكون فراغ بين الارقام يعني ممكن اكتب 1 و2 بعدين روو فارغ بعدين ارقام 

واحتاجه في شغلي ضروري واتمنى تنحل بالمعادلات اذا في امكانية واكون لك من الشاكرين

 

 

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

 كان يجب توضيح هذا الأمر مسبقاً

من الصعب جداً عمل ذلك بالمعادلات  لانه يمكن ان يكون هناك اكثر من ورقتي عمل

 يمكنك تجربة هذا الكود

Option Explicit
Sub get_all_1()
Dim Sh As Worksheet
Dim Arr(), I%, k%, m%, x%, t%
Dim My_rg  As Range
 m = 2
For Each Sh In Sheets
 If UCase(Sh.Name) <> UCase("salim") Then
  ReDim Preserve Arr(k)
    Arr(k) = Sh.Name
    k = k + 1
 End If
 Sheets("Salim").Range("B:B").ClearContents

Next Sh
 For k = LBound(Arr) To UBound(Arr)
    With Sheets(Arr(k))
       x = .Cells(Rows.Count, 2).End(3).Row
       Set My_rg = .Range("b2:b" & x).SpecialCells(2)
       My_rg.Copy Sheets("Salim").Range("B" & m)
       m = Sheets("Salim").Cells(Rows.Count, 2).End(3).Row + 1
    End With
 Next k
 Sheets("Salim").Range("B1") = "Data"
 Erase Arr
End Sub

الملف من جديد

H_Rady_1.xlsm

[أحمد يوسف]

hassan rady

أيوه بعد كل هذه الإجابات الممتازة فين انت من كل هذه الحلول ؟!!!

أين الضغط على الإعجاب لكود الأستاذ سليم ,,, بارك الله فيه ؟!!!

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