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

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


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





مدموج :استفسار في كود ترحيل

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


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


21-09-2021 07:07 مساء
saad mohamed
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-08-2019
رقم العضوية : 14161
المشاركات : 78
الجنس : ذكر
تاريخ الميلاد : 12-5-1973
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 65
 offline 

الاستاذ الكبير / ياسر خليل
تحية طيبة وبعد
انا حاولت اطبق كود الملف القديم علي هذا الملف ولكن حدث خطا ومش عارف الخطأ فين
ارجو التوضيح لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب الموضوع مدموج من مواضيع متعدّدة
 
 
  سيلا.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(2717.673) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
السلام عليكم أخي الكريم بها نبدأ أي موضوع (لا تنسى القاء السلام) - وأفشوا السلام بينكم

لابد من التفريق بين الأكواد ومواضعها ، فهناك أكواد توضع في موديول عادي وأكواد توضع في موديول الفورم وأكواد توضع في موديول ورقة العمل وأكواد توضع في موديول المصنف

الأكواد في الملف لا توضع كلها في مكان واحد ..
الكود التالي يوضع في موديول عادي
Option Explicit

Sub Test()
    Dim a, ws As Worksheet, sh As Worksheet, s As String, i As Long, ii As Long, k As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("مجمع صفوف")
        Set sh = ThisWorkbook.Worksheets("غياب")
        With ws
            a = .Range("A3:P" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
            'من هنا يتم تحديد الأعمدة في المصفوفة والمطلوب ترحيلها
            a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{3,14}])
            ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
            s = sh.Range("AE1").Value
            sh.Range("A9").CurrentRegion.Offset(1).ClearContents
            If IsEmpty(s) Then Exit Sub
            sh.Columns(2).NumberFormat = "@"
            sh.Columns(3).NumberFormat = "@"
            For i = LBound(a, 1) To UBound(a, 1)
                If a(i, 2) = s Then
                    k = k + 1
                    b(k, 1) = k
                    b(k, 2) = a(i, 1)
                    b(k, 3) = a(i, 2)
                End If
            Next i
            If k > 0 Then sh.Range("A9").Resize(k, UBound(b, 2)).Value = b
        End With
    Application.ScreenUpdating = True
End Sub


لاحظ أن اسم الإجراء هو Test (ويفضل التسمية باللغة الإنجليزية - هذا من وجهة نظري) ... ولاحظ أنه سنستخدم اسم الإجراء Test في الكود الآخر

الكود الآخر يوضع في حدث ورقة العمل التي يحدث فيها تغيير وهي ورقة العمل المسماة "غياب" ، نعمل عليها كليك يمين ثم نختار الأمر View Code ونلصق الكود هناك في حدث ورقة العمل
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    'هذا الإجراء يوضع في حدث ورقة العمل وليس في موديول
    'ويعني في حالة إحداث تغيير في الخلية المشار إليها بعنوانها يتم تنفيذ التالي
    If Target.Address = "$AE$1" Or Target.Address = "$AE$1:$AF$2" Then
        'يتم استدعاء الكود باسمه
        Call Test
    End If
End Sub
عرض الإجابة




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

17-09-2021 09:45 مساء
مشاهدة مشاركة منفردة [2]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif مدموج :استفسار في كود ترحيل
أخي الكريم
يرجى عدم تكرار المشاركات بدون داعي
تصميم الملف سيء في حقيقة الأمر ولا داعي لتنسيق كل خلايا العمل طالما أنها غير مستخدمة لأن ذلك سيجعل حجم الملف كبير ويكون الملف ثقيل في التعامل معه
عموماً جرب الأكواد التالية علها تفي بالغرض إن شاء الله
في موديول عادي ضع الكود التالي
Sub Test()
    Dim a, ws As Worksheet, sh As Worksheet, s As String, i As Long, ii As Long, k As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("1")
        Set sh = ThisWorkbook.Worksheets("سعد")
        With ws
            a = .Range("A3:O" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
            a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,3,2,9,10,11,5,14,15}])
            ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
            s = sh.Range("F5").Value
            sh.Range("A9").CurrentRegion.Offset(1).ClearContents
            If IsEmpty(s) Then Exit Sub
            sh.Columns(3).NumberFormat = "@"
            sh.Columns(8).NumberFormat = "@"
            For i = LBound(a, 1) To UBound(a, 1)
                If a(i, 8) = s Then
                    k = k + 1
                    b(k, 1) = k
                    For ii = 2 To UBound(a, 2)
                        b(k, ii) = a(i, ii)
                    Next ii
                End If
            Next i
            If k > 0 Then sh.Range("A10").Resize(k, UBound(b, 2)).Value = b
        End With
    Application.ScreenUpdating = True
End Sub


وفي حدث ورقة العمل ضع الكود التالي ليعمل الكود عند إحدات تغيير في الخلية F5 (مع العلم أنه من الأفضل أن تتجنب دمج الخلايا لأن ذلك يتعارض في حالات كثيرة مع الأكواد)
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$F$5" Or Target.Address = "$F$5:$F$7" Then
        Call Test
    End If
End Sub

17-09-2021 11:11 مساء
مشاهدة مشاركة منفردة [3]
saad mohamed
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-08-2019
رقم العضوية : 14161
المشاركات : 78
الجنس : ذكر
تاريخ الميلاد : 12-5-1973
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 65
 offline 
look/images/icons/i1.gif مدموج :استفسار في كود ترحيل
اشكرك شكرا جزيلا وجعله الله في ميزان حسناتك
وانا اسف علي سوء تنسيق الجدول

ولي طلب عند حضرتك
لوانا عايز الغي الجزئية الخاصة بمسح البيانات
الغي الجزئية دي من الكود   sh.Range("A9").CurrentRegion.Offset(1).ClearContents
صح كده

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

17-09-2021 11:52 مساء
مشاهدة مشاركة منفردة [5]
saad mohamed
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-08-2019
رقم العضوية : 14161
المشاركات : 78
الجنس : ذكر
تاريخ الميلاد : 12-5-1973
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 65
 offline 
look/images/icons/i1.gif مدموج :استفسار في كود ترحيل
معلش انا بتعبك معايا
انا بكتب بيانات في الصفوف الأولي يعني  (1 : 9 ) وعايز البيانات دي ثابتة لا تتغير ---------- في شيت ( سعد )
ماذا افعل ؟ وشكرا جزيلا

18-09-2021 12:36 صباحا
مشاهدة مشاركة منفردة [6]
هانى على
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 480
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
يتابعهم : 5
يتابعونه : 4
قوة السمعة : 855
عدد الإجابات: 8
 offline 
look/images/icons/i1.gif مدموج :استفسار في كود ترحيل
saad mohamed
فين انت من ده كله ؟!!!
لابد من الضغط على الإعجاب  28 لهذه الإجابة الممتازة المقدمة من استاذنا الكبير والقدير الأستاذ ياسر ... وهذا أقل ما يقدم لصاحب الفضل عليك فى حل مشكلتك وتفريج كربتك 


الصفحة 1 من 2 < 1 2 > الأخيرة »


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


 










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

الساعة الآن 06:20 مساء