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

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

قام بنشر (معدل)

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

Sub salim_rows()
    Dim t%, lr%, x%, z%, a%
    Dim my_rg As Range, k%
    Dim In_box, Col As Integer

    
    Application.ScreenUpdating = False
    
    If ActiveSheet.Name <> "m" Then GoTo End_Me
    del_Empty_rows
    In_box = Application.InputBox("How Many Rows", , 14)

    a = In_box - 1 'number of rows for every group
    z = 3 'number of rows to be insert every time
    x = 8 'first row to begine
    If a <= 0 Then Exit Sub
    t = x + a + 1
    If z > 5 Then z = 5

    '----------------------------------------
    'العمود الثاني
    Col = 2
    'لإيجاد آخر سطر للعمود الثاني .. فهو يذهب لآخر الصفحة ثم يعود للخلف ليقف على آخر سطر
    'lr = Cells(Rows.Count, 2).End(3).Row
    lr = Cells(Rows.Count, Col).End(xlUp).Row
    'تقوم بإرجاع كائن نطاق يمثل كافة الخلايا الفاضية في العمود الثاني
    'Set my_rg = Range("B" & x & ":B" & lr).SpecialCells(4)
    On Error Resume Next
    Set my_rg = Range(Cells(x, Col), Cells(lr, Col)).SpecialCells(xlCellTypeBlanks)
    '----------------------------------------
    
    my_rg.EntireRow.Delete
    
    On Error GoTo 0
    
    Do Until Cells(t, "B") = ""
        Rows(t).Resize(z).Insert
        Sheets("m").Range("My_DEB").Copy _
        Cells(t, 1)
        t = t + a + z + 1
    Loop
End_Me:

    Application.ScreenUpdating = True
End Sub

 

تم تعديل بواسطه AbuuAhmed
  • Like 2
قام بنشر

بارك الله فيك استاذي الاستاذ AbuuAhmed الكود يعمل بكفاءة ولكن اطمع في كرمك ...... اريد حذف الدباجة نهائيا من الورقة وكود الحذف نفس الكود السابق عند تغير اي رقم لايستجيب انظر

pic.jpg

  • أفضل إجابة
قام بنشر
5 ساعات مضت, بلانك said:

كود الحذف نفس الكود السابق عند تغير اي رقم لايستجيب انظر

حياك الله أخي، لقد شرحت الكود في المشاركة السابقة، وها أنا أضع لك التعديل مرة أخرى لتركز فيه أكثر:
 

    '----------------------------------------
    Col = 2     'العمود الثاني .. رقم الجلوس
    'لإيجاد آخر سطر للعمود الثاني .. فهو يذهب لآخر الصفحة ثم يعود للخلف ليقف على آخر سطر
    lr = Cells(Rows.Count, Col).End(xlUp).Row
    'تقوم بإرجاع كائن نطاق يمثل كافة الخلايا الفاضية في العمود الثاني
    Set my_rg = Range(Cells(x, Col), Cells(lr, Col)).SpecialCells(xlCellTypeBlanks)
    '----------------------------------------

من الطبيعي إذا بدلت في الأرقام دون معرفتها ومعرفة جدواها ستوقف الكود.
توضيح للأرقام:
الرقم 2 هو رقم عمود رقم الجلوس وهو الرقم الوحيد الذي يمكنك التعديل عليه عند إزاحة/تغيير موقع العمود وبشرط أن لا تستخدم أسفل العمود أي يكون عند نهاية خاليا حتى نهاية الصفحة.
الرقم 3 هو قيمة الرمز xlUp ويعني للأعلى، وهذا لا تلمسه بالمرة.
الرقم 4 هو قيمة الرمز xlCellTypeBlanks ويعني الخلايا الفاضية. وهذ كذلك لا تلمسه بالمرة.

بالنسبة لوظيفة الكود لم أحاول فهمه وخصوصا من بصمته تعرفت على كاتبه وهو من الخبراء المتمكنين والذي لا يمكنني أن أعدل على أكواده، فرجاءً تواصل معه لأي تعديل منعا للإحراج.

تحياتي واعتذاري.

  • Like 1
قام بنشر

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

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