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

**ناصر سعيد** · أبريل 8, 2016

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

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

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



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

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

**ناصر سعيد** · أبريل 9, 2016

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

**ناصر سعيد** · أبريل 11, 2016

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

**ناصر سعيد** · أبريل 18, 2016

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

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

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

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

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

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

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

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

ياسر خليل أبو البراء · أبريل 19, 2016

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

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

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

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

Call DoIt

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

Application.ScreenUpdating = True

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

تقبل تحياتي

**ناصر سعيد** · أبريل 19, 2016

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

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

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

ياسر خليل أبو البراء · أبريل 19, 2016

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

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

Application.ScreenUpdating=True

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

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

**ناصر سعيد** · أبريل 19, 2016

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

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

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

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



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 بواسطه ناصر سعيد

**ناصر سعيد** · أبريل 19, 2016

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

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

ياسر خليل أبو البراء · أبريل 19, 2016

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

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

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

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

**ناصر سعيد** · أبريل 19, 2016

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

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

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

هذا هو الملف

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

ياسر خليل أبو البراء · أبريل 19, 2016

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

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

قم بحذف الأكواد الموجودة في موديول رقم 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

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

تقبل تحياتي

**ناصر سعيد** · أبريل 19, 2016

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

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

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

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

ليه ؟

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

جزاك الله خير

ياسر خليل أبو البراء · أبريل 19, 2016

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

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

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

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

ياسر خليل أبو البراء · أبريل 19, 2016

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

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

**ناصر سعيد** · أبريل 20, 2016

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

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

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

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

ياسر خليل أبو البراء · أبريل 20, 2016

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

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

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

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

**ناصر سعيد** · أبريل 20, 2016

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

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

اكتشفت انه

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

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

ولكن

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

ياسر خليل أبو البراء · أبريل 20, 2016

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

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

تقبل تحياتي

**ناصر سعيد** · أبريل 20, 2016

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

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

        lngRow = rngEnd.Row - 1

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

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

ياسر خليل أبو البراء · أبريل 20, 2016

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

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

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

**ناصر سعيد** · أبريل 20, 2016

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

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

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

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

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

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

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

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

ياسر خليل أبو البراء · أبريل 20, 2016

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

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

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

قبل هذا السطر

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

**ناصر سعيد** · أبريل 21, 2016

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

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

كودك راااائع

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

ياسر خليل أبو البراء · أبريل 21, 2016

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

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

تقبل تحياتي

تسجيل الدخول

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

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

من فضلك سجل دخول لتتمكن من التعليق

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information