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

[ناصر سعيد]

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

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

[ناصر سعيد]

اخي الكريم ياسر

الكود اكثر من رااائع

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

 

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

4 ساعات مضت, ناصر سعيد said:

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

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

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

الموضوع أبسط مما تتخيل .. يمكنك مع نهاية الكود المسمى DoIt أن تضع السطر التالي

Sheets("بيانات الطلبة").Activate

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

CopyRow "اسم ورقة العمل", رقم الصف المراد نسخه, رقم آخر عمود تريد التعامل معه

غير ما يلزم ليعمل معك الكود بعد التعديل عليه

حيث أن الإجراء المسمى CopyRow يليه "اسم ورقة العمل بين أقواس تنصيص"

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

ثم فاصلة ثم اذكر رقم آخر عمود به بيانات وهذا أيضاً قد تم عمله بهذا الشكل نظراً لوجود خلايا مدمجة والعمود متغير من ورقة إلى أخرى ..

فتم وضع الإجراء بهذا الشكل ليكون مرن مع أي ورقة عمل

تقبل تحياتي

[ناصر سعيد]

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

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

يعني لو كتبنا 25 في صفحة بيانات المدرسه يتم نسخ 26 صف

ربنا يجعلها لك دائما سهله ربنا يبارك لك

 

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

دور في الكود على +1 وشيل الجزء ده .. حاول تتبع أسطر الكود لتفهم كيف يسير الكود أخي الكريم ناصر

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

 

[ناصر سعيد]

اخي الكريم المحترم ياسر

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

جاري التجارب للوصول الى الافضل  ... عموما الى الان كود خرافيي

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

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

لكي تتبع الكود سطر بسطر يمكنك استخدام مفتاح F8 من لوحة المفاتيح وتفتح نافذة اللوكال لمتابعة أسطر الكود

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

الرابط من هنا

[ابن بنها]

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

'
Sub CopyRow(sSheet As String, sRow As Long, LC As Long)

'إلغاء تحديث الشاشة
' (الغاء مشاهدة تنفيذ الماكرو)
        Application.ScreenUpdating = False

    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 "ورقة " & sSheet & " غير موجودة.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    
    
 '[B10] تعيين قيمة للمتغير ليساوي قيمة الخلية
  'من صفحة بيانات المدرسة
    cnt = Sheets("بيانات المدرسة").Range("B10").Value

    Ws.Range(Ws.Cells(sRow, 1), Ws.Cells(sRow, LC)).Copy
    Ws.Range("A" & sRow).Resize(cnt).PasteSpecial xlPasteAll
    On Error Resume Next
    
   ' يقوم بمسح الخلايا الثابتة في النطاق المنسوخ بحيث
      ' يبقى على المعادلات والتنسيق فقط ويزيل ما دون ذلك
    Ws.Range("A" & sRow).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents
    Application.CutCopyMode = False

End Sub

Sub DoIt()
    CopyRow "بيانات الطلبة", 7, 22
    CopyRow "إنجاز1", 7, 26
    CopyRow "رصد الترم الأول", 7, 108
    CopyRow "أعمال السنة", 7, 26
    CopyRow "رصد الترم الثانى", 7, 189
    CopyRow "كنترول شيت", 11, 189
    Range("A1").Activate
    
    ' تحديث الشاشة
        Application.ScreenUpdating = True

End Sub

 

 

لو سمحتم اريد شرح باقي الاكواد كما في الموديول

سؤال ليه اول الكود سطره طويل جدا مش كنا بنعمله بسيط ياخد اسم الكود فقط مثلا Sub CopyRow  فقط

وايه فايدة الريسايز .. شكرا

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

أخي الكريم ابن بنها

أول سطر طويل لأنه يحتوي على اسم الإجراء الفرعي وهذا الإجراء لا يطبق بشكل مباشر بل يتم استدعائه من إجراء آخر (مثل الدوال المعرفة) ولذا تجد السطر طويل ويحتوي على بارامترات أي مدخلات يقوم المستخدم بإدخالها .. والمدخلات هي رقم الصف المراد نسخه ورقم آخر عمود تريد التعامل معه ..

لاحظ الإجراء الفرعي المسمى DoIt ستجد الأسطر تعتمد على هذا الإجراء الفرعي الأول المسمى CopyRow ..

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

 

رابط فهرس الموضوعات من هنا

 

ادرس الكود بشكل جيد وإذا صادفك أي سطر غير مفهوم فلتخبرنا به وإن شاء الله نفيدك بقدر ما نستطيع

تقبل تحياتي

[ابن بنها]

[ناصر سعيد]

اخي الكريم المحترم ياسر  ...

اريد وضع كودكم الرائع مع فورمه لكلمه سز وهتاخد كلمه السر من

خليه زد 3        .. في صفحة بيانات الطلبه

'
Sub CopyRow(sSheet As String, sRow As Long, LC As Long)


'إلغاء تحديث الشاشة
' (الغاء مشاهدة تنفيذ الماكرو)
        Application.ScreenUpdating = False

    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 "ورقة " & sSheet & " غير موجودة.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    
    
 '[B10] تعيين قيمة للمتغير ليساوي قيمة الخلية
  'من صفحة بيانات المدرسة
    cnt = Sheets("بيانات المدرسة").Range("B10").Value

    Ws.Range(Ws.Cells(sRow, 1), Ws.Cells(sRow, LC)).Copy
    Ws.Range("A" & sRow).Resize(cnt).PasteSpecial xlPasteAll
    On Error Resume Next
    
   ' يقوم بمسح الخلايا الثابتة في النطاق المنسوخ بحيث
      ' يبقى على المعادلات والتنسيق فقط ويزيل ما دون ذلك
    Ws.Range("A" & sRow).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents
    Application.CutCopyMode = False

End Sub

Sub DoIt()
    CopyRow "بيانات الطلبة", 7, 22
    CopyRow "إنجاز1", 7, 26
    CopyRow "رصد الترم الأول", 7, 108
    CopyRow "أعمال السنة", 7, 26
    CopyRow "رصد الترم الثانى", 7, 189
    CopyRow "كنترول شيت", 11, 189
    Range("A1").Activate
    
    ' تحديث الشاشة
        Application.ScreenUpdating = True

End Sub 

 

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

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

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

لم أفهم طلبك بشكل جيد ..بالنسبة للفورم أنا لست متمكن في التعامل مع الفورم ..

ربما يتدخل أحد الأعضاء ويكمل معك طلبك بخصوص الفورم ...

تقبل تحياتي

[ناصر سعيد]

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

فورمه.rar

Private Sub CommandButton1_Click()
If TextBox1.Text = Sheets("بيانات الطلبة").Range("Z1") Then
Me.Hide
TextBox1.Text = ""
MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب"
    Application.ScreenUpdating = False
    Columns("c:d").Select
    Selection.EntireColumn.Hidden = False
    Range("f7").Select
    Range("b7").Select
    Application.ScreenUpdating = True
Unload Me
Else
MsgBox "عفوا كلمة المرور خاطئة و لن يتم تنفيذ المطلوب"
TextBox1.Text = ""
TextBox1.SetFocus
End If
End Sub




Private Sub TextBox1_Change()

End Sub

Private Sub UserForm_Click()

End Sub

 

[ناصر سعيد]

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

[ناصر سعيد]

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

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

إخواني الكرام

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

برجاء تدخل أحد الاخوة للمساعدة ..

[ناصر سعيد]

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

[ناصر سعيد]

للرفع

 

[ناصر سعيد]

 

اضفط ALT +F11   اضغط على الفورمه مرتين سيظهر شكل الغورمه

اضغط على شكل الفورمه ثم ضع هذا الكود

Private Sub CommandButton1_Click()
If TextBox1.Text = Sheets("بيانات الطلبة").Range("Z1") Then
Me.Hide
TextBox1.Text = ""
MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب"
    Application.ScreenUpdating = False
    
    
 
    
    CopyRow "بيانات الطلبة", 7, 22
    CopyRow "إنجاز1", 7, 26
    CopyRow "رصد الترم الأول", 7, 108
    CopyRow "أعمال السنة", 7, 26
    CopyRow "رصد الترم الثانى", 7, 189
    CopyRow "كنترول شيت", 11, 189
    Range("A1").Activate
 
 




'إلغاء تحديث الشاشة
' (الغاء مشاهدة تنفيذ الماكرو)
        Application.ScreenUpdating = False

    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 "ورقة " & sSheet & " غير موجودة.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    
    
 '[B10] تعيين قيمة للمتغير ليساوي قيمة الخلية
  'من صفحة بيانات المدرسة
    cnt = Sheets("بيانات المدرسة").Range("B10").Value

    Ws.Range(Ws.Cells(sRow, 1), Ws.Cells(sRow, LC)).Copy
    Ws.Range("A" & sRow).Resize(cnt).PasteSpecial xlPasteAll
    On Error Resume Next
    
   ' يقوم بمسح الخلايا الثابتة في النطاق المنسوخ بحيث
      ' يبقى على المعادلات والتنسيق فقط ويزيل ما دون ذلك
    Ws.Range("A" & sRow).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents
    Application.CutCopyMode = False




    ' تحديث الشاشة
        Application.ScreenUpdating = True

Unload Me
Else
MsgBox "عفوا كلمة المرور خاطئة و لن يتم تنفيذ المطلوب"
TextBox1.Text = ""
TextBox1.SetFocus
End If
End Sub




Private Sub TextBox1_Change()

End Sub

Private Sub UserForm_Click()

End Sub

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

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

Sub نسح()
UserForm2.Show
End Sub

 

 

 

 

بارك الله لكم

[ابن بنها]

حاولت اجربها على ملف مش راضيه تشتغل ... حلها الله يبارك لك عايز حل ربط الفورمه مع الكود

 

[ابن بنها]

استاذ ياسر

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

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

أخي الكريم ابن بنها

أنا مشكلتي إني ضعيف جداً في التعامل مع الفورم ..

إن شاء الله الأخ سعيد ناصر يقدم لك المساعدة بخصوص تلك النقطة حيث أنه من خلال رده تبين لي أن توصل للحل وكيفية عمل المطلوب ..

تقبل تحياتي

[ابن بنها]

استاذ ياسر اصدقاءك كتير ومنهم اللي يجيد ذلك حلها الله يبارك لك

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

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

التحلي بالصبر مطلوب .. تعلم الصيد يكسبك الصبر

[ناصر سعيد]

اخي الاستاذ ياسر

يسر الله له امره واخي الاستاذ ابن بنها .. بارك الله فيه

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

ادعو الله ان يرزقنا باحد الاخوه الذين يستطيعون الحل جزاكم وجزاهم الله خيرا