ناصر سعيد

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

بارك الله فيك وبك ولك

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

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

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

جزاكم الله خيرا اريد وضع كلمة مرور لهذا الكود المرفق بالملف http://www.officena.net/ib/applications/core/interface/file/attachment.php?id=110780

يارب .. يسر الامور

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

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

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

بسم الله الرحمن الرحيم احبابنا في الله ابشركم وأبشر نفسي بقدوم رجل من افضل الرجال خلقا وعلما وهو الاستاذ المحترم / عبد الله المجرب فأرجو الحفاوة لمقدمه بما يليق بمكانته العظيمه

احبابي في الله السلام عليكم ورحمة الله وبركاته ارجو وضع هذا الكود بالملف الموجود بمعنى اخر اريد وضع هذا الكود في الفورمه الموجوده بالملف 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 http://www.officena.net/ib/applications/core/interface/file/attachment.php?id=110780 وجزاكم الله خيرا

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

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

يوجد بالملف زر لاظهار السري .. اضغط عليه مرة وشوف .. عايزين نعمل زي كده لايوجد باسوورد في زر اظهار السري

جزاك الله خيرا استاذ ياسر اولا هذا هو الكود 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 وهذا كود و شكل الفورمة http://www.officena.net/ib/applications/core/interface/file/attachment.php?id=110537 وهذا هو الملف ادراج عدد محدد من الصفوف بصيغ الصف الحالى فى اوراق محددة2.rar شكراا لله اولا ثم شكرا لك اخي استاذ ياسر جزاك الله خيراااا

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

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

اضفط 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 بارك الله لكم

للرفع

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

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

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

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

اريدكم حفظكم الله ان تضع الكود السابق ... مع هذه الفورمه فورمه.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