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

[ناصر سعيد]

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

اخواني في الله هذا الملف به كود لاحد عمالقة المنتدى

وهو الاستاذ ابو تامر بارك الله له ولكم

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

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

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

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

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

Option Base 1
Sub Test()
MySheets = Array("ورقة1", "ورقة2", "ورقة3")
R = ActiveCell.Row
Count = 2
If vRows = 0 Then
    Count = Application.InputBox(Prompt:=" ادخل عدد الصفوف ", Title:="    ادراج عدد محدد من صفوف ", Default:=1, Type:=1)
    If Count = False Then Exit Sub
End If
Application.ScreenUpdating = False
For x = 1 To UBound(MySheets)
    Sheets(MySheets(x)).Select
    Rows(R).Offset(1, 0).Resize(Count).EntireRow.Insert: Rows(R).AutoFill Rows(R).Resize(Count + 1), xlFillDefault
    Rows(R).Offset(1).Resize(Count).EntireRow.SpecialCells(xlConstants).ClearContents
Next
Sheets(MySheets(1)).Select
Application.ScreenUpdating = True

End Sub

الكود هو

 

 

 

[ياسر خليل أبو البراء]

أخي الكريم ناصر

الكود غير متوافق مع الملف المرفق ..يرجى إرفاق الملف الأصلي الذي يحتوي كود أ / تامر للإطلاع عليه ودراسته أولاً ..

أو قم بالإشارة إلى الموضوع المقتبس منه الكود

تقبل تحياتي

 

[ناصر سعيد]

شكرا لردك ربنا يبارك فيك

هذا هو

 

[ياسر خليل أبو البراء]

أخي الكريم ناصر

اطلعت على الموضوع وفهمت الفكرة من الكود لكن لم أفهم المطلوب بالنسبة لك بشكل تام

وضح بشكل تفصيلي ما هي اوراق العمل المراد العمل عليها ؟ وما هي شروطك ؟ وما هي حيثيات الطلب بالضبط؟

تقبل تحياتي

[ناصر سعيد]

جزاك الله كل خير اخي المحترم ياسر خليل

في صفحة بيانات اساسيه

يوجد عدد في الخليه B10

هذا العدد متغير لانه عدد طلبه الصف الدراسي وكل صف دراسي له عدد مختلف ...

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

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

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

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

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

وشكرا مقدما

 

[ناصر سعيد]

للرفع رفع الله مقداركم

[ياسر خليل أبو البراء]

أتعني أنك تريد الاستغناء عن صندوق الإدخال الموجود في الكود الأصلي لأبو تامر والاعتماد على القيمة 888 في ورقة بيانات المدرسة ..

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

إن شاء الله سأعمل على ملفك إذا تيسر لي الوقت

تقبل تحياتي

[ناصر سعيد]

نعم اخي الكريم اريد الاستغناء عن صندوق الادخال

والاعتماد على الزر  الذي يجلب عدد الصفوف من صفحة بيانات المدرسه

لان 888 متغير بارك الله لك

[ناصر سعيد]

Sub KH_Copy()
On Error Resume Next
Dim Last As Long
Dim Count As Integer
Count = 1
Count = Sheets("KHBOOR").Range("F9").Value
With ActiveSheet
         A = .Cells(1, 1).End(xlDown).Offset(2, 0).Row
         .Range(Cells(A, 1), Cells(Rows.Count, 5)).EntireRow.Delete
         Last = .Range("A" & .Rows.Count).End(xlUp).Row
    .Rows(Last).Copy .Rows(Last).Resize(Count)
    .Rows(Last).Resize(Count).SpecialCells(xlConstants).ClearContents
End With
On Error GoTo 0
End Sub

هل يمكن تطويع هذا الكود ليعمل في ملقي المرفق بالمشاركة الاولى

 

 

نسخ صفوف بعدد معين مع الاحتفاظ بالمعادلات.rar

عايز اي حل يا احبابي

[ياسر خليل أبو البراء]

أخي الكريم ناصر

إليك شرح الكود الأخير لتتمكن من تطويعه لخدمة ملفك

Sub KH_Copy()
    'الإعلان عن المتغيرات
    Dim Last As Long, A As Long
    Dim Count As Integer
    
    'سطر لتفادي حدوث خطأ في حالة أن الخلايا التي سيتم مسحها أي الخلايا الثابتة كانت فارغة
    On Error Resume Next
        'تعيين قيمة للمتغير ليساوي 1
        Count = 1
        '[F10] تعيين قيمة للمتغير ليساوي قيمة الخلية
        Count = Sheets("KHBOOR").Range("F10").Value
        
        'بدء التعامل مع ورقة العمل النشطة
        With ActiveSheet
            'تعيين رقم الصف الذي يمثل أول صف فارغ بعد آخر صف به بيانات
            A = .Cells(1, 1).End(xlDown).Offset(2, 0).Row
            'حذف صفوف النطاق بداية من الصف رقم 13
            .Range(Cells(A, 1), Cells(Rows.Count, 5)).EntireRow.Delete
            'تعيين آخر صف به بيانات وهو الصف رقم 12 والذي يعتبر أول صف به المعادلات المطلوب نسخها
            Last = .Range("A" & .Rows.Count).End(xlUp).Row
            'نسخ الصف الهدف بامتداد قيمة المتغير أي بالعدد المحدد أو العدد المطلوب
            .Rows(Last).Copy .Rows(Last).Resize(Count)
            'مسح الثوابت والإبقاء على المعادلات
            .Rows(Last).Resize(Count).SpecialCells(xlConstants).ClearContents
        End With
    On Error GoTo 0
End Sub

ها هو الشرح طالما أن الأخوة يعجزون عن تقديم حل للموضوع ..

تقبل تحياتي

 

[ابن بنها]

Sub MacroFil1()
Application.ScreenUpdating = False
Sheets("بيانات الطلبة").Range("a7:o7").Select
     Selection.AutoFill Destination:=Range("a7:o" & ['الرئيسية'!s12] + 6)
    Sheets("رصد نصف العام").Select
    Range("a7:n7").Select
     Selection.AutoFill Destination:=Range("a7:n" & ['الرئيسية'!s12] + 6)
    Sheets("ملف الإنجاز1 ").Select
    Range("a7:k7").Select
     Selection.AutoFill Destination:=Range("a7:k" & ['الرئيسية''!s12] + 6)
    Sheets("رصد آخر العام ").Select
    Range("a7:cd7").Select
     Selection.AutoFill Destination:=Range("a7:cd" & ['الرئيسية'!s12] + 6)
     Sheets("بيانات الطلبة").Select
    Range("A4").Select
 Application.ScreenUpdating = True
End Sub

اخي الكريم ناصر سعيد

وجدت الحل في احدى مشاركات الاخوة الكرام في هذا الرابط

والكود المستخدم له فكره اخرى ولكن تؤدي نفس الغرض الذي تريده ان شاء الله

Sub MacroFil1()
Application.ScreenUpdating = False
Sheets("بيانات الطلبة").Range("a7:o7").Select
     Selection.AutoFill Destination:=Range("a7:o" & ['الرئيسية'!s12] + 6)
    Sheets("رصد نصف العام").Select
    Range("a7:n7").Select
     Selection.AutoFill Destination:=Range("a7:n" & ['الرئيسية'!s12] + 6)
    Sheets("ملف الإنجاز1 ").Select
    Range("a7:k7").Select
     Selection.AutoFill Destination:=Range("a7:k" & ['الرئيسية''!s12] + 6)
    Sheets("رصد آخر العام ").Select
    Range("a7:cd7").Select
     Selection.AutoFill Destination:=Range("a7:cd" & ['الرئيسية'!s12] + 6)
     Sheets("بيانات الطلبة").Select
    Range("A4").Select
 Application.ScreenUpdating = True
End Sub

شرح للكود

السطر الأول فى الكود هو اسم الماكرو

السطر الثانى هو إلغاء تحديث الشاشة (الغاء مشاهدة تنفيذ الماكرو)

السطر الثالث تحديد البيانات الموجودة فى أول صف من صفوف بيانات الطلاب من الخلية (a7)إلى الخلية (o7)

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

من السطر الخامس حتى السطرالثالث عشر تكرار نفس عمليتى التحديد والنسخ فى الصفحات ( رصد نصف العام - ملف الإنجاز1 - رصد آخر العام )

حتى تكون الصفحات جاهزة لأستقبال وربط البيانات

السطر الرابع عشر الرجوع إلى صفحة بيانات الطلبة السطر الخامس عشر الوقوف فى الخلبة (a4)

السطر السادس عشر عكس السطر الثانى

السطر السابع عشر نهاية الكود

وحيث إنك من رجال التربية والتعليم

أهديك هذا الكود وهو من تراث المنتدى الطيب برجاله

Sub إظهار()
Dim Answer As String
    Answer = InputBox(" فضلاَ أدخل كلمة المرور  ")
    If Answer <> Sheets("بيانات الطلبة").Range("S2") Then
     MsgBox "كلمة المرور غير صحيحة ولم يتم تنفيذ المطلوب "
    Exit Sub
    End If
        MsgBox "كلمة المرور صحيحة وسيتم تنفيذ المطلوب "
Columns("c:d").Select
    Selection.EntireColumn.Hidden = False
    Columns("s:s").Select
    Selection.EntireColumn.Hidden = True
    Range("b7").Select

End Sub

 

تم تعديل مارس 28, 2016 بواسطه ابن بنها
تنسيق الكتابه

[ابن بنها]

رابط سيفيدك في عمل كنترول لمدرستك ودعواتنا للجميع بالخير

http://www.officena.net/ib/profile/16499-%D8%B9%D8%A7%D8%AF%D9%84-%D8%AC%D9%84%D8%A7%D9%84/?do=content&page=1

[ابن بنها]

اريد ان احعل هذا في توقيعي .. كيف

http://up.top4top.net/downloadf-top4...b00a1-rar.html خطوط البسمله
http://up.top4top.net/downloadf-top4...ca0c1-rar.html خطوط الخطاط
http://www.arfonts.net/?c=diwan&t=symbol خطوط الديواني
http://www.arfonts.net/?c=thuluth خطوط الثلث
http://www.arfonts.net/?c=naskh

[ياسر خليل أبو البراء]

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

 

[ابن بنها]

في ٢٨‏/٣‏/٢٠١٦ at 15:24, ابن بنها said:

اريد ان احعل هذا في توقيعي .. كيف

http://up.top4top.net/downloadf-top4...b00a1-rar.html خطوط البسمله
http://up.top4top.net/downloadf-top4...ca0c1-rar.html خطوط الخطاط
http://www.arfonts.net/?c=diwan&t=symbol خطوط الديواني
http://www.arfonts.net/?c=thuluth خطوط الثلث
http://www.arfonts.net/?c=naskh

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

 

[ياسر خليل أبو البراء]

أخي الكريم ناصر سعيد

المشكلة في ملفك وجود الخلايا المدمجة في رأس العمود في أوراق العمل مما يسبب مشاكل مع الكود ..

الرجاء محاولة بناء الملف بدون خلايا مدمجة لأنها تتعارض مع الأكواد ..لأنه من المعروف أن الدمج عدو الأكواد .. ولاحظ الملفات التي قمت بإرفاقها لا يوجد فيها دمج ...أو كحل آخر يمكن إدراج صف تحت الخلايا المدمجة ثم تخفيه فيما بعد .. ويكون هذا الصف هو الأساس ..

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

[ناصر سعيد]

تقضل استاذ ياسر المرفق بدون دمج

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

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

 

 

1ادراج عدد محدد من الصفوف 2.rar

[ياسر خليل أبو البراء]

 

أخي العزيز ناصر سعيد

إليك الكود التالي عله يفي بالغرض

حمل الكود من هنا

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

تقبل تحياتي

 

[ناصر سعيد]

جزاك الله خيرا مش عارف احمل الكود الموقع ......

ارجو وضع الكود مباشره في المنتدى او http://www.up-00.com/

ولك خالص شكري وتقديري

[ناصر سعيد]

جزاك الله خيرا مش عارف احمل الكود الموقع ......

ارجو وضع الكود مباشره في المنتدى او

http://www.up-00.com/

ولك خالص شكري وتقديري

او احد الاحوه اللي نجحوا في تحميل الكود يعيد رفعه ويجزيه الله خيرا

[ياسر خليل أبو البراء]

تفضل أخي الكريم

رغم أن الموضوع بسيط ..بيظهر معاك كذا صفحة بتنتظر لمدة 5 ثواني وتضغط على Skip Ad .. ودا بيتكرر 4 أو 5 مرات (كنوع من الدعم البسيط لي)

عموماً تفضل الكود وجرب وأعلمني بالنتيجة

Sub CopyRow(sSheet As String, sRow As Long, LC As Long)
    Dim Ws As Worksheet
    Dim cnt As Long

    On Error Resume Next
        Set Ws = Sheets(sSheet)
    On Error GoTo 0

    If Ws Is Nothing Then
        MsgBox "Sheet " & sSheet & " Doesn't Exist In The Workbook.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If

    cnt = Sheets("بيانات المدرسة").Range("B10").Value

    Ws.Range(Ws.Cells(sRow, 1), Ws.Cells(sRow, LC)).Copy
    Ws.Range("A" & sRow).Resize(cnt + 1).PasteSpecial xlPasteAll
    On Error Resume Next
    Ws.Range("A" & sRow + 1).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents
    Application.CutCopyMode = False
End Sub

Sub DoIt()
    CopyRow "بيانات الطلبة", 7, 19
    CopyRow "إنجاز1", 7, 15
    CopyRow "رصد الترم الأول", 7, 29
    CopyRow "أعمال السنة", 7, 15
    CopyRow "رصد الترم الثانى", 7, 102
    CopyRow "كنترول شيت", 12, 114
End Sub

تقبل تحياتي

[ناصر سعيد]

راااااااااااااااااااااااائع يا ابو المفهوميه يا استاذ ياسر خليل

الكود سريع وسهل .. الله يحفظك ويبارك لك .. الله يحفظك ويبارك لك   .. الله يحفظك ويبارك لك

... ولكن بعد اجراء الكود الصفحات تظهر باللون الداكن كأنها محده فممكن لو تكرمت نزيل هذا التحديد

ممكن شرح لهذه الاسطر

   Ws.Range("A" & sRow + 1).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents
    Application.CutCopyMode = False

 

هذه الاكواد ستعمل مع اكواد حمايه .. لعدم التعارض فقط

[ياسر خليل أبو البراء]

أخي الكريم ناصر

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

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

تقبل تحياتي

[ناصر سعيد]

ربنا يبارك لك وموضوع ظهور التحديد هل يمكن ازالته

[ياسر خليل أبو البراء]

يمكن إزالة التحديد ولكن هذا يتطلب تنشيط ورقة العمل وتشيط الخلية A1 مثلاً

الأمر بسيط حاول تستخدم السطر التالي

Ws.Activate

هذا السطر لتنشيط الكود ، والسطر التالي لتنشيط الخلية A1

Range("A1").Activate

وإن كنت لا أحبذ استخدام هذه الخاصية .. لأنها تثقل من عمل الكود ..