مطلوب تقسيم الارقام على صفحات

[وليد ابو عمر]

السلام عليكم... يوجد في المرفقات صفحة اكسل بها مجموعة ارقام.. واريد ان يتم تقسيم كل 3 ارقام في صفحة مستقلة.. حيث ان لدي العديد من الارقام ولن اقدر على تقسيمهم يدوي... وشكرا لكم 

ارقام.rar

ويكون التقسيم في صفحة مستقلة وليس في ورقة تالية من الصفحة الاساسية

[جمال عبد السميع]

بصراحة أخى الطلب غير واضح ياريت ترسل مرفق أخر به النتيجة المتوقعة من طلبك

تقبل تحياتى

 

[ياسر خليل أبو البراء]

أستاذي ومعلمي وأخي الحبيب جمال

عوداً حميداً .. لقد افتقدناك كثيراً والله

تقبل وافر حبي واحترامي

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

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

http://www.officena.net/ib/topic/64192-معاينة-محددة/#comment-417279

سؤال بسيط للادارة : كيف يمكن التراجع عن رفع ملف تم ادراجه الخطا؟ و عملية الحذف لا تستجيب

Sub copy_every_3()
    Application.ScreenUpdating = False
    y = 0
    x = Sheets.Count
    t = x
   If t > 1 Then
        On Error Resume Next
        For i = 2 To t
        Application.DisplayAlerts = False
        Sheets(i).Delete
        Next
        Else
   End If

lr = Sheets(1).Cells(Rows.Count, 1).End(3).Row
        For k = 0 To lr Step 3
        
         Sheets(1).Range("a" & k + 1 & ":a" & k + 3).Copy
        
         Sheets.Add After:=Sheets(Sheets.Count)
         ActiveSheet.Name = "list" & Chr(y + 65)
         ActiveSheet.Range("a1").PasteSpecial (xlValues)
         ActiveSheet.Columns(1).AutoFit
         y = y + 1
 Next
 Sheets(1).Range("a1").Select
 Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

My_print_Set_Up.zip

تم تعديل أكتوبر 15, 2015 بواسطه سليم حاصبيا

[ياسر خليل أبو البراء]

أخي الحبيب سليم يرجى رفع الملف المرفق مرة أخرى

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

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

اخي ياسر 

لقد حاولت حذفه كما اشرت لي و لكن لا فائدة 

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

على كل حال هذا الملف الذي وضعته مع الكود

كما يمكن الاطلاع على الملف لسابق لابداء الرأي حوله (اعتقد لا مانع من ذلك)

every 3 cells in sheet.zip

تم تعديل أكتوبر 15, 2015 بواسطه سليم حاصبيا

[وليد ابو عمر]

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

ارقام.rar

[ياسر خليل أبو البراء]

أخي الكريم وليد أبو عمر

هل اطلعت على مرفق الأخ الحبيب سليم؟

أعتقد أنه يؤدي الغرض ..

إذا وجدت أية ملاحظات يرجى وضعها للمناقشة

[وليد ابو عمر]

 أستاذي الجليل ياسر خليل أبو البراء لقد حملت الملف الذي وضعه الأخ سليم ولم اجد اي تعديل في الملف يمكنك تنزيله والاطلاع عليه

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

حاول استبدال الماكرو بهذا (لا توجد اخطاء)

Sub copy_every_3()
    Application.ScreenUpdating = False
    y = 0
       x = Sheets.Count
   Do While x > 1
   Application.DisplayAlerts = False
   Sheets(x).Delete
   x = x - 1
   Loop

Application.DisplayAlerts = True
lr = Sheets(1).Cells(Rows.Count, 1).End(3).Row
        For k = 0 To lr Step 3
        
         Sheets(1).Range("a" & k + 1 & ":a" & k + 3).Copy
        
         Sheets.Add After:=Sheets(Sheets.Count)
         ActiveSheet.Name = "list" & Chr(y + 65)
         ActiveSheet.Range("a1").PasteSpecial (xlValues)
         ActiveSheet.Columns(1).AutoFit
         ActiveSheet.Range("a1").Select
         y = y + 1
 Next
 Sheets("ورقة1").Activate
 Range("a1").Select
 Application.CutCopyMode = False
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
End Sub

 

تم تعديل أكتوبر 16, 2015 بواسطه سليم حاصبيا

[ياسر خليل أبو البراء]

أخي الحبيب سليم وضع الكود في حدث ورقة العمل

يمكنك إدراج موديول جديد وقص الكود من حدث ورقة العمل إلى الموديول ثم إنشاء زر وربطه بالكود

أو لو أحببت ارفقت لك الملف مرة أخرى به التعديلات المطلوبة

[وليد ابو عمر]

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

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

تفضل اخي الملف جاهز وتحت لطلب

و لمزيد من الخيارات ----- الملف الثاني

 

every 3 cells in sheet salim.zip

 

every 3 cells in sheet salim advanced.zip

تم تعديل أكتوبر 17, 2015 بواسطه سليم حاصبيا

[ياسر خليل أبو البراء]

أخي الحبيب سليم

بارك الله فيك على هذه الهدايا القيمة

بالنسبة للكود فهو رائع حقاً ولكن هناك نقطة في غاية الأهمية ألا وهي البيانات إذا كانت كثيرة جداً ربما يواجه المستخدم مشكلة

لنفترض أن لديك 200 رقم وسيتم تقسيمهم كل 3 في ورقة عمل ..أي أنه سيلزم للأمر 66 ورقة ..

في الكود اعتمدت على تسمية أوراق العمل باسم List ثم حرف من الحروف ، والحروف 26 حرف فقط بالتالي سيحدث خطأ ..

أمر آخر : أفضل وضع الأكواد في موديول ..

يمكن تعديل الكود بهذا الشكل

Sub CopyEveryN()
    Dim LR As Long, Y As Long, N As Long, X As Long, K As Long
    LR = Sheets(1).Cells(Rows.Count, 1).End(3).Row
    Y = 0
    N = [C1]
    
    If Not IsNumeric(N) Or N <= 0 Then
        MsgBox "اكتب عدداً صحيحاً", 64: Exit Sub
        If N >= LR Then N = 1
    End If

    N = Int(N)
    X = Sheets.Count
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        Do While X > 1
            Sheets(X).Delete
            X = X - 1
        Loop
    
        For K = 0 To LR Step N
            Sheets(1).Range("A" & K + 1 & ":A" & K + N).Copy
            Sheets.Add After:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = "List" & Y + 1
                .Range("A1").PasteSpecial xlValues
                .Columns(1).AutoFit
                .Range("A1").Select
            End With
            Y = Y + 1
        Next
    Application.Goto Sheet1.Range("A1")
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

أخي الحبيب سليم حاول تراعي الإعلان عن المتغيرات ..

تقبل وافر تقديري و تحياتي

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

اخي ياسر مشكور جداً على هذا التعليق

لاحطت ان هناك خطأ بسيط في الكود يتمثل في هذا اللسطر: المفروض انه في حالة تحطي عدد الصفوف ان تكون N=lr

وليس N=1   يرجى الانتباه الى هذا الامر

If N >= LR Then N = 1

 

every 3 cells in sheet salim advanced.zip

تم تعديل أكتوبر 17, 2015 بواسطه سليم حاصبيا

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

اخي ياسر 

اليك المزيد حول هذا الموضوع

 

every n cells in sheet salim ++.zip