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

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

محمد عبدالرحمن 1
 مشاركة

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

محمد عبدالرحمن 1

محمد عبدالرحمن 1

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

السلام عليكم

 

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

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

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


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

ادراج صفوف لاسفل بنفس التنسيق والمعادلات دون التأثير على عملية الجمع 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 = ) 

 

محمد عبدالرحمن 1

محمد عبدالرحمن 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

محمد عبدالرحمن 1

محمد عبدالرحمن 1

قام بنشر
  • الكاتب
قام بنشر

استاذ ابوعيد

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

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

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

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

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

ولكم  الشكر

 

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

محمد عبدالرحمن 1

محمد عبدالرحمن 1

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

استاذ ابوعيد

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

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

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

مرفق صوره 

وكذالك المعادلة في عامود 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

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

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع
×
×
  • اضف...

Important Information

  I accept