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

كود اضافت صف بالمعادلات والاكواد في نطاق محدد وليس تحت اخر صف مرفق ملف - رجاء دخول الخبراء تكرما


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

السلام عليكم

 

بحثت في المنتدى الشامخ ووجدت هذا العمل لاحد الاخوه

ولكن يوجد مشكلة صغبرة 

كيف اجعل اضافت الصف تكون في الجدول الاول في نطاق محدد وليس تحت اخر صف 


بنتظار المساعدة 
بارك الله فيكم 

ادراج صفوف لاسفل بنفس التنسيق والمعادلات دون التأثير على عملية الجمع 2017.rar

تم تعديل بواسطه محمد عبدالرحمن 1
رابط هذا التعليق
شارك

 

.

 

ياكرام ساعدوني بارك الله فيكم

امـــــــــــــــــــــــــــــــــــــــــــــــــــــــــــل

المساعــــــــــــــــــــ بنتظاركم ــــــــــــــــــــدة

 

 

.

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

الكود هو

Sub Kh_Insert_Rows()
Dim r
r = ActiveCell.Row

    Range("A" & r).Resize(1, 7).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

End Sub

حاول أن تضع هذا الكود داخل زر (إضافة صفوف جديدة ) وتمسح الكود السابق

ثم بعد ذالك حدد أي خلية وشغل الكود سيتم إضافة صفوف مكان الخلية المحددة

إذا لم تنجح العملية معاك راسلني على الأي ميل الظاهر تحت اسمي حتى ارسل لك الملف كاملا

تحياتي

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

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

ادرج هذا الكود بدلا من الكود الموجود

Sub CmdInsertRw()
    Dim lRow As Long
    Dim lRsp As Long
    On Error Resume Next
    lRow = Application.InputBox(Prompt:="ادخل رقم الصف المراد ادخال الصف بعده", _
    Title:="ادراج عدد محدد من صفوف ", Default:=1, Type:=1)
    lRsp = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & 1, _
    Title:="ادراج عدد محدد من صفوف ", Default:=1, Type:=1)
 If lRsp = False Then Exit Sub
    Rows(lRow).Select
    Selection.Copy
    Rows(lRsp).Selec
    Selection.Insert Shift:=xlDown
    Rows(lRow + 1).PasteSpecial xlPasteFormulasAndNumberFormats
        Application.CutCopyMode = False
End Sub

وغير المعادلة الموجودة فى ( A3 )  الى  (  A3 - 1 = ) 

 

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

 

.

 

استاذ زيزو العجوز 

يعطيك العافيه ومشكور مقدما 

 

جربت  الكود اصبح يضيفصف واحد فقط مع المعادلات والاكواد 

يعني ليسى حسب الاختيار

 

وغيرت المعادلة الى   الى  (  A3 - 1 = ) 

ولكن لا يقبل

ارجو منك التكرم بوضعها في الملف وارفقه

ولك الشكر

 

.

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

تم تطوير الكود ليناسب طلبك

Sub Kh_Insert_Rows()
Dim r, s, x, c
r = ActiveCell.Row
s = InputBox("ÃÏÎá ÚÏÏ ÇáÕÝæÝ ÇáãÑÇÏ ÃÖÇÝÊåÇ", "ÅÖÇÝÉ ÇáÕÝæÝ", 1)
If r < 4 Then Exit Sub
Application.ScreenUpdating = False
For x = 1 To s
    Range("A" & r).Resize(1, 7).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next

Range("A" & r - 1).AutoFill Destination:=Range("A" & r - 1).Resize(s + 1, 1), Type:=xlFillDefault
Range("D" & r - 1).Resize(1, 4).AutoFill Destination:=Range("D" & r - 1).Resize(s + 1, 4), Type:=xlFillDefault
c = Range("A3").End(xlDown).Row
Range("A3").FormulaR1C1 = "=MAX(R2C:R[-1]C)+1"
    Range("A3").AutoFill Destination:=Range("A3:A" & c)

Range("A3:A" & c) = Range("A3:A" & c).Value
Application.ScreenUpdating = True
End Sub

إضافة الصفوف سيكون من بداية الصف الرابع وما بعده

يعني لن تستطيع إضافة صقوق في الصف الثالث

تحياتي

إضافة صفوف.rar

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

استاذ ابوعيد

انت مبدع يعطيكم العافيه جيعا على تفاعلكم الرائع
ولكن اساذي
واريدة يضيف 20 خليلة بصف واحد
فيها تنسيق مختلف بعضها قائمة منسدلة وترقيم تلقائي واكود

وانت يبدو لي اضفت المعادلة نفسها الجمع بالاكواد

وانا اقصد ياخذ كبي نسخة  من سطر كامل
هو السطر السادس كامل ويضيفة العدد حسب الطلب في اخر الجدول
بجميع مافيه من اكواد وقائمة منسدلة وغيرها

وارفقت ملف يوضح الفكرة بشكل افضل وتفصيلي

ارجو منك ومن الاخوه الكرام التكرم بالمساعدة

ولكم  الشكر

 

إضافة صفو ف بالاكواد والتنسيق.rar

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

استاذ ابوعيد

والله انت مبدع

يعطيك العافيه 

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

مرفق صوره 

وكذالك المعادلة في عامود G لم تندرج في الاضافة 

 

واطلب منك لوتكرت 

كتابة توضيح وشرح تحت كل كود بالعربي لكي افهم 

واستطيع التعديل في المستقبل

يعني هو يخذ كبي نسخ من اي سطر يكررة

المدى التنسيق عمل كل سطر بالكود

 

Private Const ContColumn As Integer = 7

Sub Kh_Insert_Rows()
Dim r, s, x, c, d
'r = ActiveCell.Row
s = InputBox("أدخل عدد الصفوف المراد أضافتها", "إضافة الصفوف", 1)
'If r < 7 Then Exit Sub
Application.ScreenUpdating = False
r = Range("A6").End(xlDown).Row + 1
For x = 1 To s
    Range("A" & r).Resize(1, 18).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A" & r) = 1
Next
c = Range("A6").End(xlDown).Row
Range("A" & r - 1).AutoFill Destination:=Range("A" & r - 1).Resize(s + 1, 1), Type:=xlFillDefault
Range("C" & r - 1).Resize(1, 2).AutoFill Destination:=Range("C" & r - 1).Resize(s + 1, 2), Type:=xlFillDefault
Range("R" & r - 1).Resize(1, 1).AutoFill Destination:=Range("R" & r - 1).Resize(s + 1, 1), Type:=xlFillDefault
For d = 1 To c - 5
Range("A" & d + 5) = d
Next
'Range("A6").FormulaR1C1 = "=MAX(R2C:R[-1]C)+1"
'    Range("A6").AutoFill Destination:=Range("A3:A" & (c + s))

'Range("A6:A" & c) = Range("A6:A" & c).Value
Application.ScreenUpdating = True
End Sub

وصدقني عاجز عن الشكر لشخصك الكريم

انت ومن تفاعل

وبالانتظار

 

 

.

هذي بدون تنسيق.JPG

تم تعديل بواسطه محمد عبدالرحمن 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.

×
×
  • اضف...

Important Information