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

[حاتم عيسى]

بسم الله الرحمن الرحيم

تحية طيبة من عند الله ... وبعد

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

1 - عمل كود ترحيل البيانات من الصفحة الرئيسية إلى صفحات المواد حسب مواد الدور الثاني بمعنى ( إذا كان الطال عنده دور ثان في مادة اللغة العربية يرحل البيانات من اول رقم الجلوس و الاسم وباقسي البيانات الموجودة في صفحة اللغة العربية ) وهكذا .

2 - إذا كان الطالب عنده مااده أخرى بعد المادة التي ترحل يكتب في خانة المواد التالية عدد المواد التالية فقط أو يكتب عنده مواد تالية , وإذا لم يكن عنده مواد تالية للمادة التي ترحل يكتب ليس له مواد تاليه )

3 - عدم ترك أسطر فارغة بين البيانات المرحلة .

مرفق ملف للعمل علية

وبارك الله فيكم جميعا

وأتقدم بخالص الشكر والتقدير لكم جميعًا ولكل القائمين المنتدى الغالي .

الدور الثاني.rar

تم تعديل أغسطس 4, 2016 بواسطه حاتم عيسى

[حاتم عيسى]

الملف بعد بعض التعديلات

برجاء المساعدة للضرورة

بارك الله فيكم جميعًا

الدور الثاني444.rar

[omar elhosseini]

 

الاخ حاتم عيسى

شاهد المرفق

Omar_1.rar

 

[حاتم عيسى]

53 دقائق مضت, عمر الحسيني said:

 

الاخ حاتم عيسى

شاهد المرفق

Omar_1.rar

 

بارك الله في حضرتك عمل أكثر من رائع وممتاز

ولكن هناك نقطة صغيرة وهى مسح البيانات من الصفحات المرحل إليها قبل الترحيل حتى لا يكون هناك تكرار في البيانات .

وشكرا جزيلا لحضرتك وجعل الله جميع أعمالك في موازين حسناتك ....

تم تعديل أغسطس 5, 2016 بواسطه حاتم عيسى

[omar elhosseini]

 

الاخ حاتم عيسى

شاهد المرفق

 

Omar_2.rar

[حاتم عيسى]

Option Base 1

Sub Transfer_Data()
'
Dim Sh_Master As Worksheet
Dim Rng As Range
Dim Arr()
Application.ScreenUpdating = False
'======================================================================================
Set Sh_Master = Sheets("الرئيسية")
For Each Sh In Sheets
    If Sh.Name <> Sh_Master.Name Then
        Sh.Range("B7:H" & Rows.Count).ClearContents
    End If
Next
End_Row = Sh_Master.Cells(Rows.Count, "C").End(xlUp).Row
Set Rng = Sh_Master.Range("A6:N" & End_Row)
Arr = Rng
'======================================================================================
For Row = 2 To UBound(Arr)
    For Col = 7 To 12
        If Arr(Row, Col) = 1 Then
            ShName = Arr(1, Col)
            End_Row = Sheets(ShName).Cells(Rows.Count, "C").End(xlUp).Row + 1
            Set Rng = Range(Sh_Master.Cells(Row + 5, "B"), Sh_Master.Cells(Row + 5, "F"))
            Rng.Copy Sheets(ShName).Range("B" & End_Row)
            Sheets(ShName).Range("G" & End_Row) = Arr(1, Col)
            '==============================
            Sheets(ShName).Range("H" & End_Row) = Sh_Master.Cells(Row + 5, "N") - 1
            ' OR
            '            Sheets(ShName).Range("H" & End_Row) = "عنده مواد تالية"
            '==============================
        End If
    Next
Next
'======================================================================================
    Application.ScreenUpdating = True
'
End Sub

الأستاذ الفاضل المحترم الخلوق : عمر الحسيني

تحية من عند الله  ... وبعد

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

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

مشكووووووووووووووووووووووووووووووووور

مجهود وعمل أكثر من رائع

هل من الممكن حماية الصفحات المرحل إليها البيانات بكلمة مرور وليكن " 123 " حتى لا يتم العبث بها

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

 

تم تعديل أغسطس 5, 2016 بواسطه حاتم عيسى

[omar elhosseini]

 

الاخ حاتم عيسى

شكرا لك اخي علي كلماتك العطره

كلمة مرور  123

شاهد المرفق

 

Omar_3.rar

[حاتم عيسى]

بارك الله في حضرتك واسف على ازعاج حضرتك وكثرة الطلبات. 

[omar elhosseini]

 

لا ازعاج اخي

ولو في اي شئ اخر تحت امرك 

كلنا نساعد  بما نستطيع ابتغاء وجه الله الكريم

 

[حاتم عيسى]

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

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

فما الحل ؟

[حاتم عيسى]

بفضل الله تعالى ..... ثم بفضل الأستاذ الفاضل المحترم : ياسر خليل أبو البراء

تم تعديل الكود وحل المشكلة في المشاركة التالية

 

 

[omar elhosseini]

 

الاخ حاتم عيسى

لا يمكن حدوث  ما تقول نهائيا 

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

 

فالكود في الملف

Omar_3.rar

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

اعد التجربة علي الملف

Omar_3.rar

واخبرني النتيجة

لا يمكن نهائيا حدوث هذه الرسالة 

لا يمكن نهائيا حدوث هذه الرسالة

لا يمكن نهائيا حدوث هذه الرسالة

ارجو من الاخ ياسر تجربة الملف 

Omar_3.rar

واخباري بالنتيجة

ربما اخي حاتم عيسى تكون علي حق واكون انا في غفلة من امري

 

 

 

 

[حاتم عيسى]

الأستاذ الفاضل المحترم : عمر الحسيني

تحية طيبة ... وبعد

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

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

أعتذر لحضرتك شديد الاعتذار .

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