طلب كود ادراج صف في ورقتين

[khalid_star2005]

السلام عليكم

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

الاولى التي تكون فعالة والثانية في ورقة "احصائية المدارس

على ان تقوم بنسخ الصيغ والتنسيق من الصف العلوي

وشكراً

[khalid_star2005]

13 hours ago, khalid_star2005 said:

السلام عليكم

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

الاولى التي تكون فعالة والثانية في ورقة "احصائية المدارس

على ان تقوم بنسخ الصيغ والتنسيق من الصف العلوي

وشكراً

 

[khalid_star2005]

 

السلام عليكم

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

الاولى التي تكون فعالة والثانية في ورقة "احصائية المدارس

على ان تقوم بنسخ الصيغ والتنسيق من الصف العلوي

وشكراً

[khalid_star2005]

 

[khalid_star2005]

 

[khalid_star2005]

 

[khalid_star2005]

نحن هنا

[khalid_star2005]

[khalid_star2005]

عجيب يومين بلا رد؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟

[khalid_star2005]

وجدت الكود من موقع اجنبي بس احب اعرف سبب عدم الرد 7 ايام ؟؟؟؟؟؟؟؟؟؟؟؟؟

والكود مو صعب

 

[نبيل عبد الهادي]

هل ممكن  تعطينا الكود اخي الكريم لتعم الفائدة للجميع 

[khalid_star2005]

 @نبيل عبد الهادي

تفضل اخي

ليس لدي الخبرة في البرمجة وجدت الكود وقمت بتكراره

الجزء الاول من الكود يقوم بادراج صف في اخر صف موجود فيها بيانات بالاعتماد على العمود ( دي ) في الورقة الفعالة اي الحالية

اما الجزء الثاني هو نفس الكود ولكن تختار الورقة الثانية التي سوف يقوم بادراج الصف في اخر صف فيها بيانات بالاعتماد على العمود ( أي ) يمكنك تغيرهم حسب رغبتك

اتمنى تستفاد منها

فكرة الكود هو:-

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

ملاحظة :- الكود يقوم بنسخ الدوال والتنسيقات من الصف العلوي ولكن فارغة من البيانات

Sub Insert_row()
Dim rActive As Range

Set rActive = ActiveCell

Application.ScreenUpdating = False
With Cells(Rows.Count, "D").End(xlUp)
    .EntireRow.Copy
    With .Offset(1, 0).EntireRow
        .PasteSpecial xlPasteFormats
        .PasteSpecial xlPasteFormulas
        On Error Resume Next
            .SpecialCells(xlCellTypeConstants).ClearContents
        On Error GoTo 0
    End With
End With

rActive.Select

Application.CutCopyMode = False
Application.ScreenUpdating = True

Sheets("اكتب هنا اسم الورقة المطلوبة").Select

Set rActive = ActiveCell

Application.ScreenUpdating = False
With Cells(Rows.Count, "A").End(xlUp)
    .EntireRow.Copy
    With .Offset(1, 0).EntireRow
        .PasteSpecial xlPasteFormats
        .PasteSpecial xlPasteFormulas
        On Error Resume Next
            .SpecialCells(xlCellTypeConstants).ClearContents
        On Error GoTo 0
    End With
End With

rActive.Select

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

 

تم تعديل فبراير 9, 2017 بواسطه khalid_star2005

[نبيل عبد الهادي]

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

الكود:

()Public Sub insertRowBelow
ActiveCell.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrAbove
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1).EntireRow.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End Sub

[khalid_star2005]

23 minutes ago, نبيل عبد الهادي said:

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

مع رسالة تاكييد

اتمنى تفيدك

Private Sub cmdInsertRow_Click()

    Dim lRow As Long
    Dim lRsp As Long
    On Error Resume Next

    lRow = Selection.Row()
    lRsp = MsgBox("Insert New row above " & lRow & "?", _
            vbQuestion + vbYesNo)
    If lRsp <> vbYes Then Exit Sub

    Rows(lRow).Select
    Selection.Copy
    Rows(lRow + 1).Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False

   'Paste formulas and conditional formatting in new row created
    Rows(lRow).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone

End Sub

 

تم تعديل فبراير 9, 2017 بواسطه khalid_star2005