أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


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





كود ترحيل

الرجاء كود ترحيل من صفحة كشاف بداية من الفصل 1/4 حتى 6/6 مثل الكود الذي يرحل من الكشاف الى صفحة الجدول والكود للامانة من ..


موضوع مغلق


subject icon تمت الإجابة كود ترحيل
24-10-2021 06:41 مساء
صقر
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-06-2020
رقم العضوية : 19493
المشاركات : 39
الجنس : ذكر
تاريخ الميلاد : 11-11-1966
يتابعهم : 2
يتابعونه : 0
قوة السمعة : 51
 offline 

الرجاء كود ترحيل من صفحة كشاف بداية من الفصل 1/4 حتى 6/6 مثل الكود الذي يرحل من الكشاف الى صفحة الجدول والكود للامانة من عمل الاستاذ وجيه بارك الله فيه الترحيل الى جدول 2 ولكم جزيل الشكر
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  حصص زائدة الاول والثانى22.xlsm   تحميل xlsm مرات التحميل :(18)
الحجم :(131.206) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
السلام عليكم 
أخي الكريم لم توضح التوضيح اللازم للمشكلة بشكل مناسب ، لأن الأعضاء قد لا يفهمون الملف كما تفهمه .. أنت صاحب الملف وأدرى بكل تفاصيله من أي شخص آخر
عموماً اعتماداً على التخمين وإن كنت لا أحب أن أسلك هذا المسلك إليك الكود التالي 
ولكن قبل بداية تجربة الكود لابد أن يكون أسماء المعلمين في ورقة الكشاف في العمود BE مطابقة لأسمائهم في الكشاف نفسه ، على سبيل المثال: المعلمة "زكية" موجودة في العمود BE بينما في الكشاف نفسه توجد باسم "زكية سيد محمد" لذا وجب التنبيه على توحيد الاسم هنا وهنا
ثانياً قم بتغيير أسماء أوراق العمل باللغة الإنجليزية لسهولة التعامل معها بالأكواد فورقة الكشاف أسميتها KF وورقة الجدول2 أسميتها T2 (يمكنك تغيير الأسماء في الكود أو في الملف كما يحلو لك)

وأخيراً جرب الكود التالي عله يفي بالغرض إن شاء الله
Sub Test_YasserKhalil()
    Dim xDay, xPeriod, ws As Worksheet, sh As Worksheet, rDays As Range, rTable As Range, sTeacher As String, sT1 As String, sT2 As String, sT3 As String, sDay As String, sPeriod As String, sClass As String, sSubject As String, r As Long, i1 As Long, i2 As Long, i3 As Long, c As Long, m As Long, n As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("KF")
        Set sh = ThisWorkbook.Worksheets("T2")
        For r = 5 To 39 Step 17
            sTeacher = sh.Cells(r, 7).Value
            Select Case r
                Case 5: sT1 = sTeacher: i1 = r
                Case 22: sT2 = sTeacher: i2 = r
                Case 39: sT3 = sTeacher: i3 = r
            End Select
            Set rTable = sh.Range("D" & r + 5).Resize(10, 8)
            With rTable
                .ClearContents
                .NumberFormat = "@"
            End With
        Next r
        For r = 40 To 74 Step 2
            For c = 12 To 51
                sDay = ws.Cells(1, c).MergeArea.Cells(1, 1).Value
                sPeriod = ws.Cells(2, c).Value
                sClass = ws.Cells(r, 2).Value
                sSubject = ws.Cells(r, c).Value
                If ws.Cells(r + 1, c).Value = sT1 Then
                    m = i1
                ElseIf ws.Cells(r + 1, c).Value = sT2 Then
                    m = i2
                ElseIf ws.Cells(r + 1, c).Value = sT3 Then
                    m = i3
                Else
                    GoTo Skipper
                End If
                Set rDays = sh.Range("C" & m + 5).Resize(10)
                xDay = Application.Match(sDay, rDays, 0)
                If Not IsError(xDay) Then
                    n = m + xDay + 4
                    xPeriod = Application.Match(sPeriod, sh.Range("D" & m + 2).Resize(, 8), 0)
                    If Not IsError(xPeriod) Then
                        With sh.Cells(n, xPeriod + 3)
                            .Value = sSubject
                            .Offset(1).Value = sClass
                        End With
                    End If
                End If
Skipper:
            Next c
        Next r
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub


بعد وضع الكود اعمل كليك يمين على زر Spin Button ثم Assign Macro ثم قم باختيار الماكرو المسمى Test_YasserKhalil بحيث عندما تتغير القيم يتم تنفيذ الكود
عرض الإجابة




20-11-2021 06:55 مساء
مشاهدة مشاركة منفردة [1]
صقر
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-06-2020
رقم العضوية : 19493
المشاركات : 39
الجنس : ذكر
تاريخ الميلاد : 11-11-1966
يتابعهم : 2
يتابعونه : 0
قوة السمعة : 51
 offline 
look/images/icons/i1.gif كود ترحيل
نرجو المساعدة ولكم جزيل الشكر والتقدير


20-11-2021 09:15 مساء
مشاهدة مشاركة منفردة [2]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif كود ترحيل
السلام عليكم
الموضوع غير واضح لذا لا أجد تفاعل من الأعضاء .. الرجاء توضيح المطلوب بشيء من التفصيل مع وضع صورة لشكل النتائج المتوقعة وتوضيح أوراق العمل المطلوب العمل عليها بالضبط
لا تدع الأعضاء يخمنون المطلوب فيكون التخمين في غير محله فيضيع وقتك ووقت الأعضاء.

20-11-2021 09:25 مساء
مشاهدة مشاركة منفردة [3]
صقر
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-06-2020
رقم العضوية : 19493
المشاركات : 39
الجنس : ذكر
تاريخ الميلاد : 11-11-1966
يتابعهم : 2
يتابعونه : 0
قوة السمعة : 51
 offline 
look/images/icons/i1.gif كود ترحيل
عزيزي ا/ياسر تحية طيبة والسلام عليكم
الملف المرفق به كشاف يتم الترحيل منه الى الجدول وهذا موجود بالملف المرفق المطلوب عمل صفحة اخرى مثل صفحة الجدول ثم ترحيل البيانات اليها بدءً من الصف 40 الى الصف 75 مثل ماتم ترحيله الى الجدول الموجود حيث ان المدرسة تعمل فترتين ومطلوب جدول لكل فترة ارجو ان اكون قد اوضحت المطلوب ولك ولكل اعضاء المنتدى تحية وسلام وجزيل الشكر

21-11-2021 06:58 صباحا
مشاهدة مشاركة منفردة [4]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif كود ترحيل
السلام عليكم 
أخي الكريم لم توضح التوضيح اللازم للمشكلة بشكل مناسب ، لأن الأعضاء قد لا يفهمون الملف كما تفهمه .. أنت صاحب الملف وأدرى بكل تفاصيله من أي شخص آخر
عموماً اعتماداً على التخمين وإن كنت لا أحب أن أسلك هذا المسلك إليك الكود التالي 
ولكن قبل بداية تجربة الكود لابد أن يكون أسماء المعلمين في ورقة الكشاف في العمود BE مطابقة لأسمائهم في الكشاف نفسه ، على سبيل المثال: المعلمة "زكية" موجودة في العمود BE بينما في الكشاف نفسه توجد باسم "زكية سيد محمد" لذا وجب التنبيه على توحيد الاسم هنا وهنا
ثانياً قم بتغيير أسماء أوراق العمل باللغة الإنجليزية لسهولة التعامل معها بالأكواد فورقة الكشاف أسميتها KF وورقة الجدول2 أسميتها T2 (يمكنك تغيير الأسماء في الكود أو في الملف كما يحلو لك)

وأخيراً جرب الكود التالي عله يفي بالغرض إن شاء الله
Sub Test_YasserKhalil()
    Dim xDay, xPeriod, ws As Worksheet, sh As Worksheet, rDays As Range, rTable As Range, sTeacher As String, sT1 As String, sT2 As String, sT3 As String, sDay As String, sPeriod As String, sClass As String, sSubject As String, r As Long, i1 As Long, i2 As Long, i3 As Long, c As Long, m As Long, n As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("KF")
        Set sh = ThisWorkbook.Worksheets("T2")
        For r = 5 To 39 Step 17
            sTeacher = sh.Cells(r, 7).Value
            Select Case r
                Case 5: sT1 = sTeacher: i1 = r
                Case 22: sT2 = sTeacher: i2 = r
                Case 39: sT3 = sTeacher: i3 = r
            End Select
            Set rTable = sh.Range("D" & r + 5).Resize(10, 8)
            With rTable
                .ClearContents
                .NumberFormat = "@"
            End With
        Next r
        For r = 40 To 74 Step 2
            For c = 12 To 51
                sDay = ws.Cells(1, c).MergeArea.Cells(1, 1).Value
                sPeriod = ws.Cells(2, c).Value
                sClass = ws.Cells(r, 2).Value
                sSubject = ws.Cells(r, c).Value
                If ws.Cells(r + 1, c).Value = sT1 Then
                    m = i1
                ElseIf ws.Cells(r + 1, c).Value = sT2 Then
                    m = i2
                ElseIf ws.Cells(r + 1, c).Value = sT3 Then
                    m = i3
                Else
                    GoTo Skipper
                End If
                Set rDays = sh.Range("C" & m + 5).Resize(10)
                xDay = Application.Match(sDay, rDays, 0)
                If Not IsError(xDay) Then
                    n = m + xDay + 4
                    xPeriod = Application.Match(sPeriod, sh.Range("D" & m + 2).Resize(, 8), 0)
                    If Not IsError(xPeriod) Then
                        With sh.Cells(n, xPeriod + 3)
                            .Value = sSubject
                            .Offset(1).Value = sClass
                        End With
                    End If
                End If
Skipper:
            Next c
        Next r
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub


بعد وضع الكود اعمل كليك يمين على زر Spin Button ثم Assign Macro ثم قم باختيار الماكرو المسمى Test_YasserKhalil بحيث عندما تتغير القيم يتم تنفيذ الكود

21-11-2021 11:24 صباحا
مشاهدة مشاركة منفردة [5]
صقر
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-06-2020
رقم العضوية : 19493
المشاركات : 39
الجنس : ذكر
تاريخ الميلاد : 11-11-1966
يتابعهم : 2
يتابعونه : 0
قوة السمعة : 51
 offline 
look/images/icons/i1.gif كود ترحيل
استاذنا الغالى 
السلام عليكم ورحمته وبركاته
جزيل الامتنان والشكر 
الكود وفى وكفى وعمل المطلوب بالضبط 
جعله الله في ميزان حسناتك وجزاك خيراً بوركت وبوركت ذريتك

21-11-2021 02:08 مساء
مشاهدة مشاركة منفردة [6]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif كود ترحيل
بارك الله فيك أخي الكريم صقر وجزيت خيراً على دعواتك الطيبة
والحمد لله الذي بنعمته تتم الصالحات.



الكلمات الدلالية
ترحيل ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 12:52 مساء