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

اضافة اسطر محددة العدد بنفس التنسيق


قصي

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

وجدت كودا رائعا للاستاذ خبور

يخص اضافة سطر بنفس التنسيق

ولكننا في حاجة لتعديل علي الكود ليعمل وفقا لعدد محدد

هذا الكود مفيد في اعمال كثيرة منها

شيت المرتبات عدد الموظفين محدد

والف شكر

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

وهذا الكود

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

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

Konafa4000

لاداراج صفوف بحجم معين.rar

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

السلام عليكم

جرب هذا المرفق

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

ولكن بدون المعادلات (اعمل عليهاساحاول)

اليك المرفق

ادراج صفوف لاسفل بنفس التنسيق.rar

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

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

اولا اتأسف على التأخير،

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

ثالثا : اطلب مراجعه من الاستاذ خبور خير

ارجوا ان ينال اعجابكم

konafa4000

ادراج صفوف لاسفل بنفس والمعادلات التنسيق.rar

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

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

بارك الله فيك اخي كنافة

Option Explicit


'******************************************************

'  تعيين نطاق الخلايا التي يتم نسخها

Private Const MyRng_Copy As String = "B4:I4"

'------------------------------------------------------

' MyRng_Copy تعيين رقم العمود من النطاق

'   الذي سياخذ منه آخر صف للصق

Private Const MyColumn As Integer = 4

'******************************************************


Sub Kh_Insert_Rows()

On Error Resume Next

Dim MyRow As Integer, LastRow As Integer

MyRow = 1

MyRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & MyRow, Title:="ادراج عدد محدد من صفوف ", Default:=MyRow, Type:=1)

If MyRow = False Then Exit Sub

With Range(MyRng_Copy)

    LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count

    .Copy

    With .Offset(LastRow, 0).Resize(MyRow, .Columns.Count)

        .PasteSpecial xlPasteAll

        .SpecialCells(xlCellTypeConstants).ClearContents

    End With

    .Columns(1).Offset(LastRow, 0).Select

End With

Application.CutCopyMode = False

MsgBox "تم ادراج الصفوف المطلوبة بنجاح", 524288 + 1048576, "الحمدلله"

On Error GoTo 0

End Sub

ادراج صفوف لاسفل بنفس والمعادلات التنسيق.rar

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

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

شكر اخ خبور خير

منك دائما نستفيد

قال عمر بن الخطاب رضي الله عنه:

(تعلموا العلم، وعلموه الناس، وتعلموا له الوقار والسكينة وتواضعوا لمن تعلمتم منه ولمن علمتموه، ولا تكون جبارة العلماء فلا يقوم جهلكم بعلمكم)

تلميذ المنتدى

konafa4000

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

السلام عليكم

ملحوظة :

لمن حمل الملف قبل المشاركة هذه

يقوم بتحميل الملف مرة اخرى

لانني في الملف السابق نسيت ان اربط الثابت MyRng_Copy

بالخلايا داخل الكود

اويعدل السطر

With Range("B4:I4")
بهذا
With Range(MyRng_Copy)

تقبلوا تحياتي وشكري

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

السلام عليكم

تم اضافة زر للمسح

وبعض التعديلات لكود الاضافة

Option Explicit


'******************************************************

'  تعيين نطاق الخلايا التي يتم نسخها

Private Const MyRng_Copy As String = "B4:I4"

'------------------------------------------------------

' MyRng_Copy تعيين رقم العمود من النطاق

'   الذي سياخذ منه آخر صف للصق

Private Const MyColumn As Integer = 4

'******************************************************


Sub Kh_Insert_Rows()

On Error Resume Next

Dim MyRow As Integer, LastRow As Integer

MyRow = 1

MyRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & MyRow, Title:="ادراج عدد محدد من صفوف ", Default:=MyRow, Type:=1)

If MyRow = False Then Exit Sub

With Range(MyRng_Copy)

    LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count

    If LastRow = 0 Then LastRow = 1

    .Copy

    With .Offset(LastRow, 0).Resize(MyRow, .Columns.Count)

        .PasteSpecial xlPasteAll

        .SpecialCells(xlCellTypeConstants).ClearContents

    End With

    .Columns(1).Offset(LastRow, 0).Select

End With

Application.CutCopyMode = False

MsgBox "تم ادراج الصفوف المطلوبة بنجاح", 524288 + 1048576, "الحمدلله"

On Error GoTo 0

End Sub



-------------------------------------------------------------------

Sub Kh_Clear_Rows()

On Error Resume Next

Dim LastRow As Integer

With Range(MyRng_Copy)

    LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count

    .SpecialCells(xlCellTypeConstants).ClearContents

    If LastRow = 0 Then GoTo 1

    .Cells(2, 1).Resize(LastRow, .Columns.Count).Clear

End With

1:

MsgBox "تم المسح بنجاح", 524288 + 1048576, "الحمدلله"

On Error GoTo 0

End Sub

ادراج صفوف لاسفل بنفس والمعادلات التنسيق.rar

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

يعطيك الف عافيه استاذنا المبدع .. ربي يحفظك ويحميك

وفقك الله لما يحب ويرضى دوما

خمس على خمس

كل الود والتحيه

هل يمكن اضافة اسطر محدده تعتمد على عدد موجود في خليه

حتى لاتطهر الفورمه الاولى التي تسألنا عن عدد لسظر

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

  • 1 year later...

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

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

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

وكل عام وأنتم بخير

قال عمر بن الخطاب رضي الله عنه:

(تعلموا العلم، وعلموه الناس، وتعلموا له الوقار والسكينة وتواضعوا لمن تعلمتم منه ولمن علمتموه، ولا تكون جبارة العلماء فلا يقوم جهلكم بعلمكم)

أستاذنا الكبير / عبدالله باقشير

رائع جدا الكود بارك الله فيك

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

الاستاذ " عبد الله باقشير "

افدتنا افادك الله .......... ابداع وعطاء بلا حدود

من خلالك ومن خلال ما لمسناه من عطائك غير المحدود ( حماك المولى تعالى )

يقوم اعضاء المنتدى بتقديم كل طاقاتهم للمساعدة وتقديم العلم مثل الاساتذة رجب جاويش+ ابو حنين + محمود

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

أنا مع رأي أخي yousifsamra وهو

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

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

وجزاكم الله خير

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

السلام عليكم

اخي الشهابي

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

لكن

جرب هذا التعديل


Sub Kh_Clear_Rows()

On Error Resume Next

Dim LastRow As Integer, T As Integer

With Range(MyRng_Copy)

T = Application.InputBox(Prompt:=" ادخل عدد الصفوف التي تريد حذفها " & Chr(10) & "عدد الصفوف الافتراضية " & 1, Title:="ادراج عدد محدد من صفوف ", Default:=1, Type:=1)

    LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count

    .SpecialCells(xlCellTypeConstants).ClearContents

    If LastRow = 0 Or T > LastRow Then GoTo 1

    .Cells(LastRow - T + 1, 1).Resize(T, .Columns.Count).Clear

End With

1:

MsgBox "تم المسح بنجاح", 524288 + 1048576, "الحمدلله"

On Error GoTo 0

End Sub

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

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

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



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information