ربط فورمه بكود

[ناصر سعيد]

احبابي في الله

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

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

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

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

[ناصر سعيد]

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

 

[ناصر سعيد]

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

[ناصر سعيد]

يا اساتذه الكود  للاستاذ ياسر جزاه الله خيرا

ولكن منعا لاي خطأ من افراد الكنترول ... لابد من اضافه الفورمه الموجوده بالملف .. ارجو ربط الفورمه بالكود

حفظكم ربنا ورغاكم

يوجد بالملف زر مكتوب عليه اظهار السري

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

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

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

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

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

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

إذا كنت قد فهمت طلبك ولا أدري بالضبط هل فهمته بالشكل الصحيح أم لا

يمكنك حل مشكلتك بمنتهى البساطة

وهي استخدام السطر التالي

Call DoIt

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

Application.ScreenUpdating = True

 

وتأكد أن وضوح الطلب يساهم ويساعد في مدى استجابة الأعضاء للموضوع

تقبل تحياتي

[ناصر سعيد]

الاستاذ الكبير ياسر

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

اجهدتني هذه الاضافه وتظهر هذه الرساله

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

الرسالة واضحة جداً

ضع جملة End Sub .. وذلك بعد السطر

Application.ScreenUpdating=True

 

أي قبل الإجراء الفرعي الذي يبدأ بكلمة Sub CopyRow

الخطأ من عندك أخي الفاضل .. ركز الله يبارك فيك

[ناصر سعيد]

الاستاذ الكبير ياسر

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

ظهرت هذه الرساله

 

والكود المستخدم هاهو

Private Sub CommandButton1_Click()
If TextBox1.Text = Sheets("بيانات الطلبة").Range("Z1") Then
Me.Hide
TextBox1.Text = ""
MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب"

    Application.ScreenUpdating = False
    
  End Sub
  
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

Call DoIt
    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

 

تم تعديل أبريل 19, 2016 بواسطه ناصر سعيد

[ناصر سعيد]

وعندما وضعت End If

   ظهرت هذه الرساله

 

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

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

ما الموقف الذي وضعتك فيه؟؟ أنا لا أقصد الإهانة ... وأنا لست بأستاذ كبير إنما أنا متعلم يسعى للتعلم ................................

الأفضل أن ترفق ملفك الذي به آخر كود ..

أو قم بنسخ الكود مرة أخرى بشكل صحيح ...

[ناصر سعيد]

الاستاذ الكبير ياسر

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

انت متواضع بارك الله فيك

هذا هو الملف

 

ادراج بالفورمه.rar

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

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

الأفضل أن تتبع الخطوات بشكل صحيح ...

قم بحذف الأكواد الموجودة في موديول رقم 1 وضع هذه الأكواد مكانها

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

ثم في حدث الفورم احذف الأكواد الموجودة وضع هذه الأكواد مكانها

Private Sub CommandButton1_Click()
    If TextBox1.Text = Sheets("بيانات الطلبة").Range("Z1") Then
        Me.Hide
        TextBox1.Text = ""
        MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب"
        
        Application.ScreenUpdating = False
            Call DoIt
        Application.ScreenUpdating = True

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

 

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

تقبل تحياتي

 

[ناصر سعيد]

ربنا يجزيك الخير ... تمام التمام

تاكدت ياباشا انك متواضع بعمل الكود تمام التمام

.............

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

ليه ؟

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

جزاك الله خير

 

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

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

لا أعلم المقصود بالمسح هنا .. هل تقصد الحذف إذاً ...؟

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

عموماً سأحاول أن أفكر بالأمر ..فقط أكد لي هل تقصد بمسح الصفوف أي حذفها أم مسح محتوياتها ...؟؟

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

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

Sub CopyRow(sSheet As String, sRow As Long, LC As Long)
    Dim Ws As Worksheet
    Dim cnt As Long
    Dim rngEnd As Range
    Dim lngRow 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

    With Ws
        Set rngEnd = Range(Mid(Ws.UsedRange.Address, InStr(1, Ws.UsedRange.Address, ":") + 1))
        lngRow = rngEnd.Row - 4
        Ws.Rows(sRow + 1 & ":" & lngRow).Delete


        .Rows(sRow + 2).Resize(cnt + 1).Insert
        .Range(Ws.Cells(sRow, 1), .Cells(sRow, LC)).Copy
        .Range("A" & sRow).Resize(cnt + 1).PasteSpecial xlPasteAll
        On Error Resume Next
        .Range("A" & sRow + 1).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents
    End With
    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

 

[ناصر سعيد]

الاستاذ الكبير ياسر

لم الحظ اي تغيير في الكود يعني لم يزل الصفوف

ايه رايك لو ان الكود نفس فكره كود اضاقه صفوف

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

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

أخي الكريم جرب مرة أخرى

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

وهذه هي الأسطر التي أضيفت ..

Set rngEnd = Range(Mid(Ws.UsedRange.Address, InStr(1, Ws.UsedRange.Address, ":") + 1))
        lngRow = rngEnd.Row - 4
        Ws.Rows(sRow + 1 & ":" & lngRow).Delete

.Rows(sRow + 2).Resize(cnt + 1).Insert

 

[ناصر سعيد]

الاستاذ الكبير ياسر

بعد التجربه عدة مرات

اكتشفت انه

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

الكود ناجح جزاك الله حيرا

ولكن

 لو جعلت العدد 5 مثلا هتلاقي صفوف ظاهره اخرى غير ال5

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

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

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

تقبل تحياتي

[ناصر سعيد]

الاستاذ الكبير ياسر

جزاك الله خيرا وهذه هي الجزئيه التي غيرتها وضبطط

        lngRow = rngEnd.Row - 1

 

لكن لايتم مسح كل التنسيقات في الصفوف المزاله

يعني الصفوف تم ازالة خوطها فقط واحنا عايزين ازاله الصفوف بكامل محتوياتها

 

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

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

Ws.Rows(sRow + 1 & ":" & lngRow).Delete

صراحة بدأت لا أفهم المطلوب بشكل واضح ... وهذا يشتتني بشكل كبير

[ناصر سعيد]

لكن لايتم مسح كل التنسيقات في الصفوف المزاله

يعني الصفوف تم ازالة خطوطها فقط واحنا عايزين ازاله الصفوف بكامل محتوياتها

والصورة توضح  .... الموجود 3 صفوف ... تحت ال3 صفوف تجد لون احمر ولاتجد اي اثر لخطوط الصفحة

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

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

 

 

وقد ازالت الخطوط الاساسيه للصفحة في الصفوف المزاله

ولذلك نجد اللون الاحمر الزياده

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

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

هل هناك تنسيق شرطي في ورقة العمل؟

جرب أن تضيف السطر التالي

Ws.Rows(sRow + 1 & ":" & lngRow).Clear

قبل هذا السطر

Ws.Rows(sRow + 1 & ":" & lngRow).Delete

 

[ناصر سعيد]

الاستاذ الكبير ياسر

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

كودك  راااائع

 

 

ادراج صفوق بالفورمه.rar

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

وجزيت خيراً أخي الكريم ناصر

والحمد لله أن تم المطلوب على خير ..

تقبل تحياتي