اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by محي الدين ابو البشر,

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

السلام عليكم

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

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

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

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

AA.xlsx

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

أخي العزيز

في الملف السابق يتم التحديد من الشيت الأول الخلية 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

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

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

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

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

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

بس انا نزلت الملف اللي ارفقته في اخر مشاركة  ، به 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


 

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

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

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

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

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