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

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


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





كود الترحيل معطل

عندي في الملف المرفق في شيت TI3DADأريد ترحيل كل مستوى إلى جدوله الخاص به و استعملت في ذلك كود لأحد الأساتذة في المنتدى( ..


موضوع مغلق


subject icon تمت الإجابة كود الترحيل معطل
07-10-2021 03:00 مساء
ayoub2007
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 157
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 3
يتابعونه : 1
قوة السمعة : 106
 offline 

عندي في الملف المرفق في شيت TI3DADأريد ترحيل كل مستوى إلى جدوله الخاص به و استعملت في ذلك كود لأحد الأساتذة في المنتدى( كل الشكر و التقدير) و لكن بعد إعادة ترتيب الملف من جديد أصبح الكود لا يعمل ما الحل ؟
و يظهر لي الخطأ الملون بالأصفر في الصورة
 
  Capture.png   تحميل png Capture.png مرات التحميل :(0)
الحجم :(75.191) KB
 
  med2.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(1497.591) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
عموماً جرب التعديل التالي عله يكون المطلوب 
Sub Filter_Class()
    If ActiveSheet.Name <> "TI3DAD" Then Exit Sub
    Dim f As Worksheet
    Dim D1 As Object, D2 As Object, D3 As Object
    Dim I%, a As Boolean, b As Boolean, c As Boolean
    Dim X%, y%, m%, z%, Arr, ky
    Dim st$
    Set f = Sheets("TI3DAD")
    Set D1 = CreateObject("Scripting.Dictionary")
    Set D2 = CreateObject("Scripting.Dictionary")
    Set D3 = CreateObject("Scripting.Dictionary")
    With f
        .Range("M4").CurrentRegion.ClearContents
        .Range("X4").CurrentRegion.ClearContents
        .Range("AI4").CurrentRegion.ClearContents
        I = 5
        Do Until I = 29
            st = Mid(Trim(.Cells(I, 2)), 1, 1)
            Select Case st
                Case "3": a = True: b = False: c = False
                Case "2": b = True: a = False: c = False
                Case Else: b = False: a = False: c = True
            End Select
            Arr = Application.Transpose(.Cells(I, 2).Resize(, 13))
            Arr = Application.Transpose(Arr)
            If a Then
                D3(z) = Join(Arr, "*"): z = z + 1
            ElseIf b Then
                D2(y) = Join(Arr, "*"): y = y + 1
            Else
                D1(X) = Join(Arr, "*"): X = X + 1
            End If
            I = I + 1
        Loop
        m = 4
        If D3.Count Then
            For Each ky In D3
                .Cells(m, "M").Resize(, 13) = Split(D3(ky), "*")
                m = m + 1
            Next ky
        End If
        m = 4
        If D2.Count Then
            For Each ky In D2
                .Cells(m, "X").Resize(, 13) = Split(D2(ky), "*")
                m = m + 1
            Next ky
        End If
        m = 2
        If D1.Count Then
            For Each ky In D1
                .Cells(m, "AI").Resize(, 13) = Split(D1(ky), "*")
                m = m + 1
            Next ky
        End If
        .Range("M4").CurrentRegion.Value = .Range("M4").CurrentRegion.Value
        .Range("X4").CurrentRegion.Value = .Range("X4").CurrentRegion.Value
        .Range("AI5").CurrentRegion.Value = .Range("AI5").CurrentRegion.Value
    End With
End Sub

عرض الإجابة




07-10-2021 03:45 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif كود الترحيل معطل
أخي الكريم
أين المشكلة؟ أين السؤال؟ أين التفاصيل؟ أين شكل النتائج المتوقعة؟!!!
للأسف رغم كل التوجيهات التي نقدمها في كل الأسئلة والموضوعات ، ما زال الأعضاء يصرون على عدم توضيح السؤال .. وهذا للأسف يجعل الأعضاء ينفرون من المنتدى ولا يقدمون على مساعدة الآخرين.

07-10-2021 04:05 مساء
مشاهدة مشاركة منفردة [2]
ayoub2007
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 157
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 3
يتابعونه : 1
قوة السمعة : 106
 offline 
look/images/icons/i1.gif كود الترحيل معطل
السلام عليكم أستاذ ياسر 
عذرا 
كود ترحيل كل مستوى إلى جدوله الخاص موجود في الموديل 02 و عند تنفيذه يظهر الخطأ  المضلل باللون الأصفر في الصورة المرفقة سابقا  أما عن النتائج المتوقعة فهي :
 
  النتائج المتوقعة.png   تحميل png النتائج المتوقعة.png مرات التحميل :(0)
الحجم :(305.804) KB
 


07-10-2021 04:10 مساء
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif كود الترحيل معطل
لم أفهم على أي أساس يتم الترحيل إلى ثلاثة جداول .. ما هو المعيار أو الشرط لعمليات الترحيل؟

07-10-2021 04:16 مساء
مشاهدة مشاركة منفردة [4]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif كود الترحيل معطل
عموماً جرب التعديل التالي عله يكون المطلوب 
Sub Filter_Class()
    If ActiveSheet.Name <> "TI3DAD" Then Exit Sub
    Dim f As Worksheet
    Dim D1 As Object, D2 As Object, D3 As Object
    Dim I%, a As Boolean, b As Boolean, c As Boolean
    Dim X%, y%, m%, z%, Arr, ky
    Dim st$
    Set f = Sheets("TI3DAD")
    Set D1 = CreateObject("Scripting.Dictionary")
    Set D2 = CreateObject("Scripting.Dictionary")
    Set D3 = CreateObject("Scripting.Dictionary")
    With f
        .Range("M4").CurrentRegion.ClearContents
        .Range("X4").CurrentRegion.ClearContents
        .Range("AI4").CurrentRegion.ClearContents
        I = 5
        Do Until I = 29
            st = Mid(Trim(.Cells(I, 2)), 1, 1)
            Select Case st
                Case "3": a = True: b = False: c = False
                Case "2": b = True: a = False: c = False
                Case Else: b = False: a = False: c = True
            End Select
            Arr = Application.Transpose(.Cells(I, 2).Resize(, 13))
            Arr = Application.Transpose(Arr)
            If a Then
                D3(z) = Join(Arr, "*"): z = z + 1
            ElseIf b Then
                D2(y) = Join(Arr, "*"): y = y + 1
            Else
                D1(X) = Join(Arr, "*"): X = X + 1
            End If
            I = I + 1
        Loop
        m = 4
        If D3.Count Then
            For Each ky In D3
                .Cells(m, "M").Resize(, 13) = Split(D3(ky), "*")
                m = m + 1
            Next ky
        End If
        m = 4
        If D2.Count Then
            For Each ky In D2
                .Cells(m, "X").Resize(, 13) = Split(D2(ky), "*")
                m = m + 1
            Next ky
        End If
        m = 2
        If D1.Count Then
            For Each ky In D1
                .Cells(m, "AI").Resize(, 13) = Split(D1(ky), "*")
                m = m + 1
            Next ky
        End If
        .Range("M4").CurrentRegion.Value = .Range("M4").CurrentRegion.Value
        .Range("X4").CurrentRegion.Value = .Range("X4").CurrentRegion.Value
        .Range("AI5").CurrentRegion.Value = .Range("AI5").CurrentRegion.Value
    End With
End Sub


07-10-2021 04:22 مساء
مشاهدة مشاركة منفردة [5]
ayoub2007
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 157
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 3
يتابعونه : 1
قوة السمعة : 106
 offline 
look/images/icons/i1.gif كود الترحيل معطل
تم المطلوب بنجاح ألف تحية و شكر أستاذ ياسر

07-10-2021 05:28 مساء
مشاهدة مشاركة منفردة [6]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif كود الترحيل معطل
بارك الله فيك أخي الكريم
والحمد لله الذي بنعمته تتم الصالحات.



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


 










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

الساعة الآن 08:14 صباحا