طلب كود ترحيل

[نادى حسين]

السلام عليكم
اقوم حالياً بعمل برنامج لشئون الطلاب وعمل القوائم تلقاياً
اريد كود ترحيل من شيت 1 و شيت 2 وشيت 3 الى شيت رقم 4

بحيث يتم نسخ طلاب شيت 1

ثم يلى ذلك طلاب شيت 2

ثم يلي ذلك طلاب شيت 3 

فى الشيت رقم 4

ومرفق ملف العمل

دمتم بكل خير

شيت القوائم.xlsx

[ابراهيم الحداد]

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

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

Sub CallData()
Dim ws As Worksheet, Sh As Worksheet
Dim LR  As Long, y As Long
Dim C As Range, Temp()
Dim Counter As Long
Set ws = Sheets("Sheet4")
t = Timer
Application.ScreenUpdating = False
  '-----------------
On Error Resume Next
ws.Range("A2:C1000").ClearContents
For Each Sh In Worksheets(Array("Sheet1", "Sheet2", "Sheet3"))
LR = Sh.Range("A" & Rows.Count).End(3).Row
Counter = Counter + LR
Next
  '-----------------
ReDim Preserve Temp(Counter, 4)
y = 0
For Each Sh In Worksheets(Array("Sheet1", "Sheet2", "Sheet3"))
For Each C In Sh.Range("A2:A" & LR)
If Len(C.Value) > 0 Then
Temp(y, 0) = C.Value
Temp(y, 1) = C.Offset(0, 1)
Temp(y, 2) = C.Offset(0, 2)
y = y + 1
End If
Next
Next
  '-----------------
If y > 0 Then ws.Range("A2").Resize(y, 4).Value = Temp
  '-----------------
Application.ScreenUpdating = True
MsgBox Round(Timer - t, 2)
End Sub

 

[نادى حسين]

أشكرك أخي الكريم أ / ابراهيم الحداد 

زادك الله من بحر علمه الواسع

[نادى حسين]

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

ترحيل بيانات شيت اعداد قوائم ثانية

ترحيل بيانات شيت اعداد قوائم ثالثة

ليصب كل ذلك في شيت اعداد قوائم المدرسة بالترتيب الصف الاول ثم الثاني ثم الثالث

ومرفق ملف العمل

دمتم بكل خير

قوائم المدرسة.xlsm

[ابراهيم الحداد]

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

اجعل الكود هكذا

Sub CallData()
Dim ws As Worksheet, Sh As Worksheet
Dim LR  As Long, y As Long
Dim C As Range, Temp()
Dim Counter As Long
Set ws = Sheets("اعداد قوائم المدرسة")
t = Timer
Application.ScreenUpdating = False
  '-----------------
On Error Resume Next
ws.Range("A3:L1000").ClearContents
For Each Sh In Worksheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة"))
LR = Sh.Range("B" & Rows.Count).End(3).Row
Counter = Counter + LR
Next
  '-----------------
ReDim Preserve Temp(Counter, 12)
y = 0
For Each Sh In Worksheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة"))
For Each C In Sh.Range("B3:B" & LR)
If Len(C.Value) > 0 Then
Temp(y, 0) = y
Temp(y, 1) = C.Value
Temp(y, 2) = C.Offset(0, 1)
Temp(y, 3) = C.Offset(0, 2)
Temp(y, 4) = C.Offset(0, 3)
Temp(y, 5) = C.Offset(0, 4)
Temp(y, 6) = C.Offset(0, 5)
Temp(y, 7) = C.Offset(0, 6)
Temp(y, 8) = C.Offset(0, 7)
Temp(y, 9) = C.Offset(0, 8)
Temp(y, 10) = C.Offset(0, 9)
Temp(y, 11) = C.Offset(0, 10)
y = y + 1
End If
Next
Next
  '-----------------
If y > 0 Then ws.Range("A2").Resize(y, UBound(Temp, 2)).Value = Temp
  '-----------------
Application.ScreenUpdating = True
MsgBox Round(Timer - t, 2)
End Sub

 

[نادى حسين]

جهد مشكور استاذنا الفاضل
جزاكم الله خيرا
كان الترتيب يبدا بالصف الثالث فقمت بتبديل اسماء الشيتات حتى بدا بالصف الاول ثم الثاني ثم الثالث
ولكن ما هو سبب وجود التايمر

 

[محمد هشام.]

بعد ادن الاستاد الكبير @ابراهيم الحداد اليك حلول اخرى لاثراء الموضوع لا اكثر 

Private Sub CommandButton1_Click()
Dim x, A(), i&, F&, Y&, lr&, last&, Wdata As Variant
Dim WSdest As Worksheet: Set WSdest = Sheets("اعداد قوائم المدرسة")
last = WSdest.Cells(Rows.Count, "a").End(xlUp).Row + 1
Application.ScreenUpdating = False
WSdest.Range("A3:L" & last).ClearContents

For Each Wdata In Sheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة"))
  lr = Wdata.Range("B" & Rows.Count).End(xlUp).Row
    x = Wdata.Range("B3:L" & lr)
For i = 1 To UBound(x, 1)
    Y = Y + 1: ReDim Preserve A(1 To UBound(x, 2), 1 To Y)
 For F = 1 To UBound(x, 2)
         A(F, Y) = x(i, F)
        Next
 Next
 With WSdest
WSdest.Range("b3").Resize(Y, UBound(A, 1)) = Application.Transpose(A)
WSdest.Range("a3") = 1
WSdest.Range("a3:a" & WSdest.Range("b" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear
End With
 Next Wdata
Application.ScreenUpdating = True
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub copy_data()
Dim dlgR As Integer, dlgi As Integer, Wdata As Variant
Dim ws As Worksheet: Set ws = Sheets("اعداد قوائم المدرسة")
With ws
Application.ScreenUpdating = False
dlgR = .Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A3:l" & dlgR).ClearContents
End With
For Each Wdata In Sheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة"))
    dlgR = ws.Range("b" & Rows.Count).End(xlUp).Row
        With Wdata
        dlgi = .Range("b" & Rows.Count).End(xlUp).Row
        .Range("b3:l" & dlgi).Copy ws.Range("b" & dlgR + 1)
ws.Range("a3") = 1
ws.Range("a3:a" & ws.Range("b" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear

End With
Next
Application.ScreenUpdating = True
End Sub

اما بالنسبة  ل

t = Timer

يمكنك الغاء الرسالة في اخر الكود فقط 

MsgBox Round(Timer - t, 2)

 

قوائم المدرسة 2.xlsm

[نادى حسين]

أشكرك أخي الكريم أ / محمد هشام
دمتم بكل خير وذادكم الله من بحر علمه الواسع ونفع بكم