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

[عبد الله السعيد]

السلام عليكم

لو سمحتم لدي ملف به ارقام جلوس طلاب  ،، الأرقام تأتي لي في شكل عمود واحد فقط 

اريد ان انقل هذه الأرقام الى جدول مرتب بشكل افقي كما في الملف المرفق   ، بحيث عند طباعتهم تكون الارقام مسلسلة خلال الصفحة الواحدة كما في الملف المرفق

واريد ان احدد قبل النقل للجدول ماهو الارقام المسموح فقط نقلها الى الجدول 

ولكم خالص الشكر

AA.xlsx

[ابو ايسل]

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

جرب هذا على حسب ما فهمت

 

 

AA.xlsx

[محي الدين ابو البشر]

عليكم السلام

جرب هذا

 

 

AA.xlsm

تم تعديل نوفمبر 18, 2021 بواسطه محي الدين ابو البشر

[عبد الله السعيد]

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

اخي الغالي  محي    هل لي ان احدد عدد الارقام  فقط اللي اريدها ان تنقل للجدول

[محي الدين ابو البشر]

أخي العزيز

في الملف السابق يتم التحديد من الشيت الأول الخلية F1

على كل استبدل الكود بهذا الكود وهو محدث عم السابق و... 

عسى يكون المطلوب

Sub test()
Dim count As Long
  With Sheets(1)
  count = InputBox("أدخل العدد المطلوب", "دخال")
    a = Application.Transpose(Array(Application.Transpose(Evaluate("row(1:" & count & ")")) _
    , Application.Transpose(.Cells(1, 1).Resize(count))))
  With Sheets(2)
   .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Resize(, 9).ClearContents
  r = 1
 For i = 0 To count / 3 Step 21
        For ii = 1 To 8 Step 3
        .Cells(2 + i, ii).Resize(21, 2) = WorksheetFunction.IfError(Application.Index _
        (a, Evaluate("row(" & r & ":" & 21 + r & ")"), Array(1, 2)), "")
        r = r + 21
Next: Next
End With
End With
End Sub

 

AA.xlsm

[محي الدين ابو البشر]

Sub test()
Dim count As Long
  With Sheets(1)
  On Error Resume Next
  count = InputBox("أدخل العدد المطلوب", "دخال")
  If count <> 0 Then
    a = Application.Transpose(Array(Application.Transpose(Evaluate("row(1:" & count & ")")) _
    , Application.Transpose(.Cells(1, 1).Resize(count))))
  With Sheets(2)
   .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Resize(, 9).ClearContents
  r = 1
 For i = 0 To count / 3 Step 21
        For ii = 1 To 8 Step 3
        .Cells(2 + i, ii).Resize(21, 2) = WorksheetFunction.IfError(Application.Index _
        (a, Evaluate("row(" & r & ":" & 21 + r & ")"), Array(1, 2)), "")
        r = r + 21
Next: Next
End With
Else: MsgBox "أدخل عدد", vbCritical, "خطأ بالإدخال"
  End If
End With
End Sub

في حال خطأ في الإدخال

[عبد الله السعيد]

بارك الله فيك اخي الغالي

بس انا نزلت الملف اللي ارفقته في اخر مشاركة  ، به 3 صفحات ، ماذا عن صفحة الجدول الثاني  ؟؟

وعند نسخ الكود الأخير ووضعته  لم يعمل معي

[عبد الله السعيد]

انا اشتغلت على الكود الثاني 

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

بارك الله فيك

Sub test()
Dim count As Long
  With Sheets(1)
  count = InputBox("أدخل العدد المطلوب", "دخال")
    a = Application.Transpose(Array(Application.Transpose(Evaluate("row(1:" & count & ")")) _
    , Application.Transpose(.Cells(1, 1).Resize(count))))
  With Sheets(2)
   .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Resize(, 9).ClearContents
  r = 1
 For i = 0 To count / 3 Step 21
        For ii = 1 To 8 Step 3
        .Cells(2 + i, ii).Resize(21, 2) = WorksheetFunction.IfError(Application.Index _
        (a, Evaluate("row(" & r & ":" & 21 + r & ")"), Array(1, 2)), "")
        r = r + 21
Next: Next
End With
End With
End Sub

 

[محي الدين ابو البشر]

عند نسخ الصفحة يجب ان تنقل إلى النهاية

إليك الملف

AA.xlsm

تم تعديل نوفمبر 20, 2021 بواسطه محي الدين ابو البشر

[عبد الله السعيد]

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

واشكرك اخي ابو ايسل على الفكرة الرائعة ايضاً

[محمد عدنان]

السلام عليكم 

اخي الكريم اذا كان اكثر من عمود و عند النقل نقوم اختيار عمود محدد شو التعديل على الماكرو ؟